perl6.ops

/*
 * Copyright (C) 2008-2011, The Perl Foundation.
 */

BEGIN_OPS_PREAMBLE

#include "parrot/parrot.h"
#include "parrot/extend.h"
#include "parrot/dynext.h"
#include "pmc_object.h"
#include "pmc_class.h"
#include "pmc_callcontext.h"
#include "pmc_sub.h"
#include "../binder/bind.h"
#include "../binder/multidispatch.h"
#include "../binder/container.h"
#include "../binder/types.h"
#include "../binder/sixmodelobject.h"

#if PARROT_HAS_ICU
#  include <unicode/uchar.h>
#endif

/* Cache some stuff for fast access. */
static INTVAL smo_id = 0;

/* The current dispatcher, for the next thing that wants one to take. */
static PMC *current_dispatcher = NULL;

END_OPS_PREAMBLE

/*

=item rakudo_dynop_setup()

Does various setup tasks on behalf of all of the other dynops.

=cut

*/
inline op rakudo_dynop_setup() :base_core {
    smo_id = pmc_type(interp, Parrot_str_new(interp, "SixModelObject", 0));
}

/*

=item find_lex_skip_current(out PMC, in STR)

Finds the lexical named $2 and returns it. However, unlike find_lex this op
skips the current sub and starts looking immediately at its outers.

=cut

*/
inline op find_lex_skip_current(out PMC, in STR) :base_core {
    PMC *ctx = CURRENT_CONTEXT(interp);
    $1 = PMCNULL;

    while (Parrot_pcc_get_outer_ctx(interp, ctx)) {
        PMC   * const outer   = Parrot_pcc_get_outer_ctx(interp, ctx);
        PMC   * const lex_pad = Parrot_pcc_get_lex_pad(interp, outer);

        if (!PMC_IS_NULL(lex_pad) && VTABLE_exists_keyed_str(interp, lex_pad, $2)) {
            $1 = VTABLE_get_pmc_keyed_str(interp, lex_pad, $2);
            break;
        }

        ctx = outer;
    }
}


/*

=item inline op x_is_uprop(out INT, in STR, in STR, in INT)

Sets a true value in $1 if character $4 in string $3 has the unicode property
named $2.

=cut

*/
inline op x_is_uprop(out INT, in STR, in STR, in INT) :base_core {
#if PARROT_HAS_ICU
    char     *cstr;
    INTVAL    ord;
    int32_t   strwhich, ordwhich;
    UProperty strprop;
    opcode_t  *handler;

    if ($4 > 0 && (UINTVAL)$4 == ($3->strlen)) {
        $1 = 0;
        goto NEXT();
    }

    ord = Parrot_str_indexed(interp, $3, $4);
    cstr = Parrot_str_to_cstring(interp, $2);

    /* try block tests */
    if (strncmp(cstr, "In", 2) == 0) {
        strwhich = u_getPropertyValueEnum(UCHAR_BLOCK, cstr+2);
        ordwhich = u_getIntPropertyValue(ord, UCHAR_BLOCK);
        if (strwhich != UCHAR_INVALID_CODE) {
            $1 = (strwhich == ordwhich);
            Parrot_str_free_cstring(cstr);
            goto NEXT();
        }
    }

    /* try bidi tests */
    if (strncmp(cstr, "Bidi", 4) == 0) {
        strwhich = u_getPropertyValueEnum(UCHAR_BIDI_CLASS, cstr+4);
        ordwhich = u_getIntPropertyValue(ord, UCHAR_BIDI_CLASS);
        if (strwhich != UCHAR_INVALID_CODE) {
            $1 = (strwhich == ordwhich);
            Parrot_str_free_cstring(cstr);
            goto NEXT();
        }
    }

    /* try property value aliases */
    strwhich = u_getPropertyValueEnum(UCHAR_GENERAL_CATEGORY_MASK, cstr);
    if (strwhich != UCHAR_INVALID_CODE) {
        ordwhich = u_getIntPropertyValue(ord, UCHAR_GENERAL_CATEGORY_MASK);
        $1 = ((strwhich & ordwhich) != 0);
        Parrot_str_free_cstring(cstr);
        goto NEXT();
    }

    /* try property */
    strprop = u_getPropertyEnum(cstr);
    if (strprop != UCHAR_INVALID_CODE) {
        $1 = (u_hasBinaryProperty(ord, strprop) != 0);
        Parrot_str_free_cstring(cstr);
        goto NEXT();
    }

    /* try script aliases */
    strwhich = u_getPropertyValueEnum(UCHAR_SCRIPT, cstr);
    if (strwhich != UCHAR_INVALID_CODE) {
        ordwhich = u_getIntPropertyValue(ord, UCHAR_SCRIPT);
        $1 = (strwhich == ordwhich);
        Parrot_str_free_cstring(cstr);
        goto NEXT();
    }

    /* unrecognized property name */
    Parrot_str_free_cstring(cstr);
    handler =  Parrot_ex_throw_from_op_args(interp, NULL,
            EXCEPTION_ICU_ERROR,
            "Unicode property '%Ss' not found", $2);
    goto ADDRESS(handler);
#else
    opcode_t * const handler = Parrot_ex_throw_from_op_args(interp, NULL,
            EXCEPTION_ICU_ERROR,
            "ICU not loaded", $2);
    goto ADDRESS(handler);
#endif
}

/*

=item bind_signature()

This is emitted into a sub to cause it's Perl 6 signature to be bound.

=cut

*/
inline op bind_signature() :base_core {
    /* Need to make sure some stuff doesn't get destroyed. */
    PMC      * const ctx         = CURRENT_CONTEXT(interp);
    PMC      * const saved_ccont = interp->current_cont;
    PMC      * const saved_sig   = Parrot_pcc_get_signature(interp, ctx);
    opcode_t * const current_pc  = Parrot_pcc_get_pc(interp, ctx);
    
    /* Obtain lexpad and other settings. */
    PMC * const lexpad        = Parrot_pcc_get_lex_pad(interp, ctx);
    const INTVAL noms_checked = PObj_flag_TEST(P6BINDER_ALREADY_CHECKED, ctx);
    STRING * error            = STRINGNULL;
    INTVAL bind_error;
    
    /* Look up signature to bind. */
    PMC * const parrot_sub  = Parrot_pcc_get_sub(interp, ctx);
    PMC *perl6_code, *signature;
    GETATTR_Sub_multi_signature(interp, parrot_sub, perl6_code);
    if (PMC_IS_NULL(perl6_code))
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                "Could not locate Perl 6 code object");
    signature = ((Rakudo_Code *)PMC_data(perl6_code))->signature;

    /* Call signature binder. */
    bind_error = Rakudo_binding_bind(interp, lexpad, signature, ctx,
        noms_checked, &error);

    /* Bind ok? */
    if (!bind_error) {
        /* Re-instate anything we may have damaged. */
        CURRENT_CONTEXT(interp) = ctx;
        interp->current_cont    = saved_ccont;
        Parrot_pcc_set_signature(interp, ctx, saved_sig);
        Parrot_pcc_set_pc(interp, ctx, current_pc);
        goto NEXT();
    }
    else {
        /* Maybe we need to auto-thread... */
        if (bind_error == BIND_RESULT_JUNCTION) {
            /* Find dispatcher and call it. */
            PMC * const dispatcher = Rakudo_types_junction_threader_get();
            PMC * const sub        = Parrot_pcc_get_sub(interp, ctx);
            PMC * call_ctx         = VTABLE_clone(interp, ctx);
            PMC * ret_cont         = Parrot_pcc_get_continuation(interp, ctx);
            PMC * p6sub;
            opcode_t *next;

            GETATTR_Sub_multi_signature(interp, sub, p6sub);
            VTABLE_unshift_pmc(interp, call_ctx, p6sub);
            Parrot_pcc_invoke_from_sig_object(interp, dispatcher, call_ctx);

            /* Invoke the original return continuation, to return junction result. */
            next = VTABLE_invoke(interp, ret_cont, expr NEXT());
            goto ADDRESS(next);
        }
        else {
            /* Nope, just normal fail... */
            opcode_t * const handler = Parrot_ex_throw_from_op_args(interp, NULL,
                    EXCEPTION_INVALID_OPERATION, "%Ss", error);
            goto ADDRESS(handler);
        }
    }
}


/*

=item perl6_set_types_mu_any(in PMC, in PMC)

Sets the top type.

=cut

*/
inline op perl6_set_types_mu_any(in PMC, in PMC) :base_core {
    Rakudo_types_mu_set($1);
    Rakudo_types_any_set($2);
}


/*

=item perl6_setup_junction_autothreading(in PMC)

Sets the junction type and auto-threader.

=cut

*/
inline op perl6_setup_junction_autothreading(in PMC, in PMC) :base_core {
    Rakudo_types_junction_set($1);
    Rakudo_types_junction_threader_set($2);
}


/*

=item perl6_set_types_ins(in PMC, in PMC, in PMC)

Sets the Int/Num/Str types.

=cut

*/
inline op perl6_set_types_ins(in PMC, in PMC, in PMC) :base_core {
    Rakudo_types_int_set($1);
    Rakudo_types_num_set($2);
    Rakudo_types_str_set($3);
}


/*

=item perl6_set_types_list_array_lol(in PMC, in PMC, in PMC, in PMC, in PMC)

Sets the List, ListIter, Array and LoL types.

=cut

*/
inline op perl6_set_types_list_array_lol(in PMC, in PMC, in PMC, in PMC, in PMC) :base_core {
    Rakudo_types_list_set($1);
    Rakudo_types_listiter_set($2);
    Rakudo_types_array_set($3);
    Rakudo_types_lol_set($4);
    Rakudo_types_parcel_set($5);
}


/*

=item perl6_set_types_enummap_hash(in PMC, in PMC)

Sets the EnumMap and Hash types.

=cut

*/
inline op perl6_set_types_enummap_hash(in PMC, in PMC) :base_core {
    Rakudo_types_enummap_set($1);
    Rakudo_types_hash_set($2);
}


/*

=item perl6_set_type_capture(in PMC)

Sets the Capture type.

=cut

*/
inline op perl6_set_type_capture(in PMC) :base_core {
    Rakudo_types_capture_set($1);
}


/*

=item perl6_set_type_code(in PMC)

Sets the Code type.

=cut

*/
inline op perl6_set_type_code(in PMC) :base_core {
    Rakudo_types_code_set($1);
}


/*

=item perl6_set_type_packagehow(in PMC)

Sets the package type.

=cut

*/
inline op perl6_set_type_packagehow(in PMC) :base_core {
    Rakudo_types_packagehow_set($1);
}


/*

=item perl6_booleanize(out PMC, in INT)

If $2 is non-zero, puts Bool::True in $1. Otherwise puts Bool::False
in.

=cut

*/
inline op perl6_booleanize(out PMC, in INT) :base_core {
    $1 = $2 == 0 ? Rakudo_types_bool_false_get() : Rakudo_types_bool_true_get();
}


/*

=item perl6_set_bools(in PMC, in PMC)

Sets and caches the False ($1) and True ($2) values to booleanize to.

=cut

*/
inline op perl6_set_bools(in PMC, in PMC) :base_core {
    Rakudo_types_bool_false_set($1);
    Rakudo_types_bool_true_set($2);
}


/*

=item perl6_box_str()

Box a native string to a Perl 6 Str.

=cut

*/
inline op perl6_box_str(out PMC, in STR) :base_core {
    PMC *type = Rakudo_types_str_get();
    $1 = REPR(type)->instance_of(interp, type);
    REPR($1)->set_str(interp, $1, $2);
}


/*

=item perl6_box_int()

Box a native int to a Perl 6 Int.

=cut

*/
inline op perl6_box_int(out PMC, in INT) :base_core {
    PMC *type = Rakudo_types_int_get();
    $1 = REPR(type)->instance_of(interp, type);
    REPR($1)->set_int(interp, $1, $2);    
}


/*

=item perl6_box_num()

Box a native floating point number to a Perl 6 Num.

=cut

*/
inline op perl6_box_num(out PMC, in NUM) :base_core {
    PMC *type = Rakudo_types_num_get();
    $1 = REPR(type)->instance_of(interp, type);
    REPR($1)->set_num(interp, $1, $2);
}


/*

=item perl6_box_bigint(out PMC, in NUM)

Return a Perl 6 Int if $2 will fit, otherwise return a Perl 6 Num.

=cut

*/
inline op perl6_box_bigint(out PMC, in NUM) :base_core {
    if ((INTVAL)$2 == $2) {
        PMC *type = Rakudo_types_int_get();
        $1 = REPR(type)->instance_of(interp, type);
        REPR($1)->set_int(interp, $1, $2);    
    }
    else {
        PMC *type = Rakudo_types_num_get();
        $1 = REPR(type)->instance_of(interp, type);
        REPR($1)->set_num(interp, $1, $2);
    }
}

/*

=item perl6ize_type(out PMC, in PMC)

Looks for Parrot-y types sneaking into Perl 6 land and maps them
into Perl 6 types.

=cut

*/
inline op perl6ize_type(out PMC, in PMC) :base_core {
    if ($2->vtable->base_type == smo_id)
        $1 = $2;
    else
        $1 = Rakudo_types_parrot_map(interp, $2);
}

/*

=item set_scalar_container_type(in PMC)

Sets the scalar container type.

=cut

*/
inline op set_scalar_container_type(in PMC) :base_core {
    Rakudo_cont_set_scalar_type($1);
}


/*

=item perl6_decontainerize(out PMC, in PMC)

Strips away any outer container, if one exists. Otherwise, no-op.

=cut

*/
inline op perl6_decontainerize(out PMC, in PMC) :base_core {
    $1 = Rakudo_cont_decontainerize(interp, $2);
}


/*

=item perl6_container_store(in PMC, in PMC)

Stores a value in a container. If it's Scalar, there's a fast path;
otherwise, calls the .STORE method.

=cut

*/
inline op perl6_container_store(in PMC, in PMC) :base_core {
    Rakudo_cont_store(interp, $1, $2, 1, 1);
}


/*

=item perl6_container_store_unchecked(in PMC, in PMC)

Stores a value in a container. If it's Scalar, there's a fast path;
otherwise, calls the .STORE method. In the fast path case, with this
op no rw or type checking is done (assumes that the compiler has
already decided that it's safe).

=cut

*/
inline op perl6_container_store_unchecked(in PMC, in PMC) :base_core {
    Rakudo_cont_store(interp, $1, $2, 0, 0);
}


/*

=item perl6_create_container_descriptor

Creates a container descriptor and puts in in $1. $2 is the type of the
descriptor to create. $3 is the 'of' type, $4 is the rw flag and $5 is
the name.

=cut

*/
inline op perl6_create_container_descriptor(out PMC, in PMC, in PMC, in INT, in STR) :base_core {
    $1 = Rakudo_create_container_descriptor(interp, $2, $3, $4, $5);
}


/*

=item perl6_assert_bind_ok(in PMC, in PMC)

Takes a potential value to bind in $1 and a container descriptor in $2
and asserts that the bind is allowed to take place.

=cut

*/
inline op perl6_assert_bind_ok(in PMC, in PMC) :base_core {
    if ($2->vtable->base_type == smo_id) {
        PMC *type = ((Rakudo_ContainerDescriptor *)PMC_data($2))->of;
        if (type != Rakudo_types_mu_get()) {
            INTVAL ok = 0;
            if ($1->vtable->base_type == smo_id) {
                PMC *value = Rakudo_cont_decontainerize(interp, $1);
                ok = STABLE(value)->type_check(interp, value, type);
            }
            if (!ok)
                Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                    "Type check failed in binding");
        }
    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Can only use perl6_assert_bind_ok on a SixModelObject");
    }
}


/*

=item perl6_var(in PMC, in PMC)

The .VAR operation. Wraps in an outer Scalar container so we can actually
operate on the underlying Scalar, if we have a container. Otherwise, $1
is just $2.

=cut

*/
inline op perl6_var(out PMC, in PMC) :base_core {
    if ($2->vtable->base_type == smo_id && STABLE($2)->container_spec != NULL) {
        $1 = Rakudo_cont_scalar_with_value_no_descriptor(interp, $2);
    }
    else {
        $1 = $2;
    }
}


/*

=item find_method_null_ok(out PMC, in PMC, in STR)

Like Parrot's find_method, but returns PMCNULL in $1 if $2 doesn't have a
method named $3 instead of throwing an exception.

=cut

*/
inline op find_method_null_ok(out PMC, in PMC, in STR) :base_core {
    $1 = VTABLE_find_method(interp, $2, $3);
}


/*

=item perl6_associate_sub_code_object()

Takes a Parrot Sub in $1 and a code object in $2 and associates the two.
Actually, it uses a field in the Parrot Sub PMC that Rakudo never makes
use of. Evil, but saves a prophash for every single code object.

=cut

*/
inline op perl6_associate_sub_code_object(in PMC, in PMC) :base_core {
    if ($1->vtable->base_type == enum_class_Sub
           || $1->vtable->base_type == enum_class_Coroutine) {
        SETATTR_Sub_multi_signature(interp, $1, $2);
        PARROT_GC_WRITE_BARRIER(interp, $1);
    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Can only use perl6_associate_sub_code_object if first operand is a Sub.");
    }
}


/*

=item perl6_code_object_from_parrot_sub()

Takes a Parrot Sub PMC and gets the Perl 6 code object associated with it.

=cut

*/
inline op perl6_code_object_from_parrot_sub(out PMC, in PMC) :base_core {
    if ($2->vtable->base_type == enum_class_Sub
           || $2->vtable->base_type == enum_class_Coroutine) {
        PMC *p6sub;
        GETATTR_Sub_multi_signature(interp, $2, p6sub);
        $1 = PMC_IS_NULL(p6sub) ? Rakudo_types_mu_get() : p6sub;
    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Can only use perl6_code_object_from_parrot_sub if second operand is a Parrot Sub.");
    }
}

/*

=item perl6_decontainerize_return_value()

If the sub is not rw, decontainerizes the return value.

=cut

*/
inline op perl6_decontainerize_return_value(out PMC, in PMC) :base_core {
    if ($2->vtable->base_type == smo_id && Rakudo_cont_is_rw_scalar(interp, $2)) {
        PMC *cur_ctx     = CURRENT_CONTEXT(interp);
        PMC *parrot_sub  = Parrot_pcc_get_sub(interp, cur_ctx);
        PMC *p6sub;
        Rakudo_Code *code;
        GETATTR_Sub_multi_signature(interp, parrot_sub, p6sub);
        code = (Rakudo_Code *)PMC_data(p6sub);
        $1 = code->rw ? $2 : Rakudo_cont_scalar_with_value_no_descriptor(interp, 
            Rakudo_cont_decontainerize(interp, $2));
    }
    else {
        $1 = $2;
    }
}

/*

=item perl6_type_check_return_value()

Gets the return type for a sub and type checks it.

=cut

*/
inline op perl6_type_check_return_value(in PMC) :base_core {
    PMC *cur_ctx     = CURRENT_CONTEXT(interp);
    PMC *parrot_sub  = Parrot_pcc_get_sub(interp, cur_ctx);
    PMC *p6sub;
    PMC *sig_pmc;
    PMC *rtype;
    GETATTR_Sub_multi_signature(interp, parrot_sub, p6sub);
    sig_pmc = ((Rakudo_Code *)PMC_data(p6sub))->signature;
    rtype = ((Rakudo_Signature *)PMC_data(sig_pmc))->rtype;
    if (!PMC_IS_NULL(rtype)) {
        PMC *decont_value = Rakudo_cont_decontainerize(interp, $1);
        if (!STABLE(decont_value)->type_check(interp, decont_value, rtype)) {
            /* XXX Awesomize. */
            Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                "Type check failed for return value");
        }
    }
}

/*

=item perl6_enter_multi_dispatch_from_onlystar_block()

Entry point to multi-dispatch over the dispatchee list in the specified
candidate.

=cut

*/
inline op perl6_enter_multi_dispatch_from_onlystar_block(out PMC) :base_core {
    PMC *cur_ctx     = CURRENT_CONTEXT(interp);
    PMC *orig_caller = Parrot_pcc_get_caller_ctx(interp, cur_ctx);
    PMC *parrot_sub  = Parrot_pcc_get_sub(interp, cur_ctx);
    PMC *perl6_code, *chosen;
    GETATTR_Sub_multi_signature(interp, parrot_sub, perl6_code);
    if (PMC_IS_NULL(perl6_code))
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                "Could not locate Perl 6 code object");
    chosen = Rakudo_md_dispatch(interp, perl6_code, cur_ctx, NULL);
    if (!PMC_IS_NULL(chosen)) {
        /* Invoke the chosen candidate; we use the existing call frame
         * and don't make a nested runloop. */
        opcode_t *addr;
        Parrot_pcc_set_signature(interp, cur_ctx, cur_ctx);
        interp->current_cont = Parrot_pcc_get_continuation(interp, cur_ctx);
        addr = VTABLE_invoke(interp, chosen, expr NEXT());
        Parrot_pcc_set_caller_ctx(interp, cur_ctx, orig_caller);
        PObj_flag_SET(P6BINDER_ALREADY_CHECKED, cur_ctx);
        goto ADDRESS(addr);
    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                "Internal error: multiple dispatcher returned a null candidate");
    }
}

/*

=item perl6_get_matching_multis()

Gets the multi dispatcher to find all candidates under the control of
the dispatcher in $2 that are applicable for capture $3. Puts an RPA
of them in $1.

=cut

*/
inline op perl6_get_matching_multis(out PMC, in PMC, in PMC) :base_core {
    $1 = Rakudo_md_get_all_matches(interp, $2, $3);
}

/*

=item perl6_get_package_through_who

Takes a type object and uses its associated symbol table (in .WHO)
to look for a package within it. It will auto-vivify the package if
non exists.

=cut

*/
inline op perl6_get_package_through_who(out PMC, in PMC, in STR) :base_core {
    if ($2->vtable->base_type == smo_id) {
        PMC *who = STABLE($2)->WHO;
        PMC *pkg = VTABLE_get_pmc_keyed_str(interp, who, $3);
        if (PMC_IS_NULL(pkg)) {
            /* Create the package object. This is just like a call:
             * pkg = PackageHOW.new_type(:name($3))
             */
            PMC *pkg_how = Rakudo_types_packagehow_get();
            PMC *old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
            PMC *meth    = VTABLE_find_method(interp, pkg_how, Parrot_str_new(interp, "new_type", 0));
            PMC *cappy   = Parrot_pmc_new(interp, enum_class_CallContext);
            VTABLE_push_pmc(interp, cappy, pkg_how);
            VTABLE_set_string_keyed_str(interp, cappy, Parrot_str_new(interp, "name", 0), $3);
            Parrot_pcc_invoke_from_sig_object(interp, meth, cappy);
            cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
            Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
            pkg = VTABLE_get_pmc_keyed_int(interp, cappy, 0);
            
            /* Install it in the outer package's .WHO. */
            VTABLE_set_pmc_keyed_str(interp, who, $3, pkg);
        }
        $1 = pkg;
    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Can only use perl6_get_package_through_who with a SixModelObject");
    }
}

/*

=item perl6_set_dispatcher_for_callee(in PMC)

Sets the dispatcher that the next thing we call that is interested
in one will take.

=cut

*/
inline op perl6_set_dispatcher_for_callee(in PMC) :base_core {
    current_dispatcher = $1;
}

/*

=item perl6_take_dispatcher()

Takes the dispatcher that was set, if any, and store it in the current
lexpad's $*DISPATCHER. Also clears the current set dispatcher so that
nothing else can take it by accident. If there's no current set dispatcher
then this is a no-op.

=cut

*/
inline op perl6_take_dispatcher() :base_core {
    if (current_dispatcher) {
        PMC *lexpad = Parrot_pcc_get_lex_pad(interp, CURRENT_CONTEXT(interp));
        VTABLE_set_pmc_keyed_str(interp, lexpad, Parrot_str_new_constant(interp, "$*DISPATCHER"),
            current_dispatcher);
        current_dispatcher = NULL;
    }
}

/*

=item perl6_find_dispatcher(out PMC)

Locates the nearest dispatcher $*DISPATCHER, vivifying it if required,
and returns it.

=cut

*/
inline op perl6_find_dispatcher(out PMC) :base_core {
    PMC     *ctx            = CURRENT_CONTEXT(interp);
    STRING  *dispatcher_str = Parrot_str_new_constant(interp, "$*DISPATCHER");
    PMC     *dispatcher     = NULL;
    
    while (!PMC_IS_NULL(ctx)) {
        /* Do we have a dispatcher here? */
        PMC *lexpad = Parrot_pcc_get_lex_pad(interp, ctx);
        if (!PMC_IS_NULL(lexpad) && VTABLE_exists_keyed_str(interp, lexpad, dispatcher_str)) {
            dispatcher = VTABLE_get_pmc_keyed_str(interp, lexpad, dispatcher_str);
            if (!REPR(dispatcher)->defined(interp, dispatcher)) {
                /* Need to vivify it. */
                PMC *old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
                PMC *meth    = VTABLE_find_method(interp, dispatcher, Parrot_str_new_constant(interp, "vivify_for"));
                PMC *cappy   = Parrot_pmc_new(interp, enum_class_CallContext);
                PMC *sub     = Parrot_pcc_get_sub(interp, ctx);
                PMC *p6sub;
                VTABLE_push_pmc(interp, cappy, dispatcher);
                GETATTR_Sub_multi_signature(interp, sub, p6sub);
                VTABLE_push_pmc(interp, cappy, p6sub);
                VTABLE_push_pmc(interp, cappy, lexpad);
                Parrot_pcc_invoke_from_sig_object(interp, meth, cappy);
                cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
                Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
                dispatcher = VTABLE_get_pmc_keyed_int(interp, cappy, 0);
                VTABLE_set_pmc_keyed_str(interp, lexpad, dispatcher_str, dispatcher);
            }
            break;
        }

        /* Follow dynamic chain. */
        ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
    }
    
    if (!dispatcher)
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "No dispatcher in scope");
    $1 = dispatcher;
}

/*

=item perl6_args_for_dispatcher(out PMC, in PMC)

Locates the callframe with the $*DISPATCHER passed and returns it.

=cut

*/
inline op perl6_args_for_dispatcher(out PMC, in PMC) :base_core {
    PMC     *ctx            = CURRENT_CONTEXT(interp);
    STRING  *dispatcher_str = Parrot_str_new_constant(interp, "$*DISPATCHER");
    PMC     *result         = NULL;
    
    while (!PMC_IS_NULL(ctx)) {
        /* Do we have a dispatcher here? */
        PMC *lexpad = Parrot_pcc_get_lex_pad(interp, ctx);
        if (!PMC_IS_NULL(lexpad) && VTABLE_exists_keyed_str(interp, lexpad, dispatcher_str)) {
            PMC *dispatcher = VTABLE_get_pmc_keyed_str(interp, lexpad, dispatcher_str);
            if (dispatcher == $2) {
                result = ctx;
                break;
            }
        }
        ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
    }
    
    if (!result)
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Could not find arguments for dispatcher");
    $1 = result;
}

/*

=item perl6_current_args_rpa(out PMC)

Gets a ResizablePMCArray containing the positional arguments passed to the
current block.

=cut

*/
inline op perl6_current_args_rpa(out PMC) :base_core {
    PMC   *cur_ctx = CURRENT_CONTEXT(interp);
    PMC   *result  = pmc_new(interp, enum_class_ResizablePMCArray);
    INTVAL args    = VTABLE_elements(interp, cur_ctx);
    INTVAL i;
    for (i = 0; i < args; i++)
        VTABLE_set_pmc_keyed_int(interp, result, i,
            VTABLE_get_pmc_keyed_int(interp, cur_ctx, i));
    $1 = result;
}


/*

=item perl6_is_list(out INT, in PMC)

Checks if the passed object is a RPA.

=cut

*/
inline op perl6_is_list(out INT, in PMC) :base_core {
    $1 = $2->vtable->base_type == enum_class_ResizablePMCArray;
}


/*

=item perl6_is_hash(out INT, in PMC)

Checks if the passed object is a (VM) hash.

=cut

*/
inline op perl6_is_hash(out INT, in PMC) :base_core {
    $1 = $2->vtable->base_type == enum_class_Hash;
}


/*

=item perl6_parcel_from_rpa(out PMC, in PMC, in PMC)

Creates a Perl 6 Parcel object from the RPA in $2, replacing
any PMCNULL elements with $3.

=cut

*/
inline op perl6_parcel_from_rpa(out PMC, in PMC, in PMC) :base_core {
    $1 = Rakudo_binding_parcel_from_rpa(interp, $2, $3);
}


/*

=item perl6_iter_from_rpa(out PMC, in PMC, in PMC)

Creates a lazy Perl 6 ListIter object from the RPA in $2
and iterates into the List at $3.

=cut

*/
inline op perl6_iter_from_rpa(out PMC, in PMC, in PMC) :base_core {
    $1 = Rakudo_binding_iter_from_rpa(interp, $2, $3);
}


/*

=item perl6_list_from_rpa(out PMC, in PMC, in PMC, in PMC)

Creates a lazy Perl 6 List object of type $3 from the RPA
in $2 and with flattening $4.

=cut

*/
inline op perl6_list_from_rpa(out PMC, in PMC, in PMC, in PMC) :base_core {
    $1 = Rakudo_binding_list_from_rpa(interp, $2, $3, $4);
}


/*

=item perl6_rpa_find_type(out INT, in PMC, in PMC, int INT, in INT)

Find the first element of RPA $2 that has type $3, starting at
index $4 and up through (but not including) index $5.  Sets $1
to be the index of the first element matching type, otherwise
$1 is set to the highest index searched.

Containerized elements are automatically skipped.

=cut

*/
inline op perl6_rpa_find_type(out INT, in PMC, in PMC, in INT, in INT)
{
    PMC *rpa     = $2;
    PMC *type    = Rakudo_cont_decontainerize(interp, $3);
    INTVAL elems = VTABLE_elements(interp, rpa);
    INTVAL last  = $5;
    INTVAL index;

    if (elems < last)  last = elems;

    for (index = $4; index < last; index++) {
        PMC *val = VTABLE_get_pmc_keyed_int(interp, rpa, index);
        if (val->vtable->base_type == smo_id
            && !STABLE(val)->container_spec
            && STABLE(val)->type_check(interp, val, type)) break;
    }

    $1 = index;
}


/*

=item perl6_shiftpush(inout PMC, in PMC, in INT)

Shifts up to $3 elements from $2, pushing each shifted onto $1.
$1 can be PMCNULL, in which case the shifted elements are
simply discarded.

*/
inline op perl6_shiftpush(inout PMC, in PMC, in INT) :base_core {
    INTVAL count = $3;
    INTVAL elems = VTABLE_elements(interp, $2);
    if (count > elems) count = elems;

    if (!PMC_IS_NULL($1)) {
        INTVAL pos = 0;
        while (count > 0) {
            VTABLE_push_pmc(interp, $1, VTABLE_get_pmc_keyed_int(interp, $2, pos));
            count--;
            pos++;
        }
    }
    if ($3 > 0)
        VTABLE_splice(interp, $2, pmc_new(interp, enum_class_ResizablePMCArray), 0, $3);
}


/*

=item capture_all_outers(in PMC)

Takes all the specified contexts and sets their outer pointers
to be this one.

=cut

*/
inline op capture_all_outers(in PMC) :base_core {
    PMC    *cur_ctx = CURRENT_CONTEXT(interp);
    INTVAL  elems   = VTABLE_elements(interp, $1);
    INTVAL  i;
    for (i = 0; i < elems; i++) {
        PMC *inner = VTABLE_get_pmc_keyed_int(interp, $1, i);
        Parrot_pcc_set_outer_ctx_func(interp, inner, cur_ctx);
    }
}


/*

=item encodelocaltime(out INT, in PMC)

The inverse of C<decodelocaltime>.

=cut

*/
inline op encodelocaltime(out INT, in PMC) :base_core {
    struct tm tm;

    tm.tm_sec  = VTABLE_get_integer_keyed_int(interp, $2, 0);
    tm.tm_min  = VTABLE_get_integer_keyed_int(interp, $2, 1);
    tm.tm_hour = VTABLE_get_integer_keyed_int(interp, $2, 2);
    tm.tm_mday = VTABLE_get_integer_keyed_int(interp, $2, 3);
    tm.tm_mon  = VTABLE_get_integer_keyed_int(interp, $2, 4) - 1;
    tm.tm_year = VTABLE_get_integer_keyed_int(interp, $2, 5) - 1900;
    /* We needn't bother setting tm_wday or tm_yday, since mktime
    is required to ignore them. */
    tm.tm_isdst = VTABLE_get_integer_keyed_int(interp, $2, 8);

    $1 = mktime(&tm);
}

/*
 * Local variables:
 *   c-file-style: "parrot"
 * End:
 * vim: expandtab shiftwidth=4:
 */