perl6.ops

/*
 * $Id$
 * Copyright (C) 2008-2009, The Perl Foundation.
 */

BEGIN_OPS_PREAMBLE

#include "parrot/dynext.h"
#include "pmc_object.h"

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

/* We cache a couple of type IDs for an op that we hit on every method call. */
static INTVAL p6s_id = 0;
static INTVAL or_id = 0;

END_OPS_PREAMBLE

/*

=item rebless_subclass(in PMC, in PMC)

Takes PMC $1 and reblesses it in-place, without any change of address, to be
an instance of class $2, where $2 is a subclass of the class of $1.

=cut

*/
inline op rebless_subclass(in PMC, in PMC) :base_core {
    PMC *value;
    INTVAL p6opaque = pmc_type(interp, string_from_literal(interp, "P6opaque"));

    /* First verify that the object's class is a superclass of the one we're
     * to re-bless it into. While we're at it, count the number of attributes
     * the current class has that the parent class does not. */
    PMC * const current_class = VTABLE_get_class(interp, $1);
    PMC * const parent_list   = VTABLE_inspect_str(interp, $2, Parrot_str_new_constant(interp, "all_parents"));
    const int num_parents     = VTABLE_elements(interp, parent_list);

    int in_parents = 0;
    int new_attribs = 0;
    int i;
    for (i = 0; i < num_parents; i++) {
        PMC * const test_class = VTABLE_get_pmc_keyed_int(interp, parent_list, i);
        if (test_class == current_class) {
            in_parents = 1;
            break;
        }
        else {
            new_attribs += VTABLE_elements(interp, VTABLE_inspect_str(interp,
                test_class, Parrot_str_new_constant(interp, "attributes")));
        }
    }
    if (!in_parents)
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Attempt to use rebless_subclass where the new class was not a subclass");

    /* Make sure we're operating on the real value, not a ObjectRef. */
    value = $1;
    while (VTABLE_isa(interp, value, Parrot_str_new_constant(interp, "ObjectRef")))
        value = VTABLE_get_pmc(interp, value);

    /* Check what we're trying to bless into is a standard Parrot class. */
    if ($2->vtable->base_type != enum_class_Class)
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Can only rebless into a standard Parrot class.");

    /* Check if the value is a parrot Object and the original class is a standard
     * Parrot Class. */
    if (value->vtable->base_type != enum_class_Object
            && current_class->vtable->base_type != enum_class_Class) {
        /* In this case, we have something from a foreign class system,
         * probably a PMC. We'll start by instantiating a new instance
         * of the derived class. */
        PMC * const new_ins = VTABLE_instantiate(interp, $2, PMCNULL);

        /* Now we do some nasty swapping around of memory. The end result is:
         *  - The proxy object from new_ins becomes the current value
         *  - The current value becomes the new instance
         *  - The new instance becomes the (now-replaced) proxy, and gets
         *    swept on the next GC run.
         * We do this by shuffling PMC headers around. It should be safe as
         * in the end we will end up with just as many PMCs existing. */
        PMC * const temp  = mem_allocate_typed(PMC);
        PMC * const proxy = VTABLE_get_attr_keyed(interp, new_ins, current_class,
                string_from_literal(interp, "proxy"));
        Parrot_block_GC_mark(interp);

        /* Using memcpy here may trigger gcc optimizations, which at this point
         * can wreak havoc on register-starved x86:
         * error: unable to find a register to spill in class 'SIREG'
         * Use memmove instead, which is slower, but isn't inlined by gcc. */
        memmove(temp, proxy, sizeof (PMC));
        memmove(proxy, value, sizeof (PMC));
        memmove(value, new_ins, sizeof (PMC));
        memmove(new_ins, temp, sizeof (PMC));

        Parrot_unblock_GC_mark(interp);
        mem_sys_free(temp);

        /* Now set any new attributes to be undef. */
        for (i = 0; i < new_attribs; i++)
            VTABLE_set_pmc_keyed_int(interp, PARROT_OBJECT(value)->attrib_store,
                i, pmc_new(interp, enum_class_Undef));

        /* And make sure the new object is of the right type. */
        new_ins->vtable = interp->vtables[p6opaque];
    }
    else if ((value->vtable->base_type != enum_class_Object && value->vtable->base_type != p6opaque)
            || current_class->vtable->base_type != enum_class_Class) {
        /* If we're here, we found a really odd state - the class claims to be
         * a standard Parrot one but the object it supposedly created is not.
         * In this case, something is probably wrong. */
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Object to be reblessed does not appear to be of the expected class.");
    }
    else {
        /* We have a standard Parrot class and object and can tweak it's guts.
         * Shuffle up attributes to the point of the difference between the number
         * of attributes in the parent and the derived class. Yes, this is evil -
         * we're diddling the object's internals. */
        for (i = 0; i < new_attribs; i++)
            VTABLE_unshift_pmc(interp, PARROT_OBJECT(value)->attrib_store,
                pmc_new(interp, enum_class_Undef));

        /* Now switch object's class pointer to point at the new class. This is
         * also evil. */
        PARROT_OBJECT(value)->_class = $2;
    }

    goto NEXT();
}

/*

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

    goto NEXT();
}


/*

=item inline op 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 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 = string_ord(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 *handler =  Parrot_ex_throw_from_op_args(interp, NULL,
            EXCEPTION_ICU_ERROR,
            "ICU not loaded", $2);
    goto ADDRESS(handler);
#endif
}


/*

=item get_next_candidate_info(out PMC, out PMC, out PMC)

Looks through the outers of our caller, until we find a Routine, for a lexical
named __CANDIDATE_LIST__. Hands this lexical back in $1, the PMC for the Routine
it was found in as $2 and the lexpad of that routine as $3. This is a fairly
special-purpose op that does just what callwith, callsame, nextwith and
nextsame need.

=cut

*/
inline op get_next_candidate_info(out PMC, out PMC, out PMC) :base_core {
    PMC     *ctx         = Parrot_pcc_get_caller_ctx(interp, CURRENT_CONTEXT(interp));
    STRING  *name        = string_from_literal(interp, "__CANDIDATE_LIST__");
    STRING  *wrapper     = string_from_literal(interp, "$!wrapper_block");
    PMC     *last_lexpad = PMCNULL;
    PMC     *last_sub    = PMCNULL;

    while (!PMC_IS_NULL(ctx)) {
        /* See if we've found a candidate list. */
        PMC *lexpad = Parrot_pcc_get_lex_pad(interp, ctx);
        PMC *clist  = VTABLE_get_pmc_keyed_str(interp, lexpad, name);
        if (!PMC_IS_NULL(clist)) {
            /* Found. Set results and we're done. */
            $1 = clist;
            if (PMC_IS_NULL(VTABLE_getprop(interp, Parrot_pcc_get_sub(interp, ctx), wrapper))) {
                $2 = Parrot_pcc_get_sub(interp, ctx);
                $3 = lexpad;
            }
            else {
                $2 = last_sub;
                $3 = last_lexpad;
            }
            break;
        }
        else {
            /* Not found; keep looking. */
            last_sub = Parrot_pcc_get_sub(interp, ctx);
            last_lexpad = lexpad;
            ctx = Parrot_pcc_get_outer_ctx(interp, ctx);
        }
    }
    if (!ctx)
        $1 = $2 = $3 = PMCNULL;

    goto NEXT();
}


/*

=item transform_to_p6opaque(inout PMC)

Takes PMC $1 and swaps out its Object vtable for a P6opaque vtable. (Expect
this op to be temporary, but for now it lets us get things in the right
kinda direction.)

=cut

*/
inline op transform_to_p6opaque(inout PMC) :base_core {
    /* Sanity check. */
    if ($1->vtable->base_type == enum_class_Object) {
        INTVAL type_id = pmc_type(interp, string_from_literal(interp, "P6opaque"));
        $1->vtable = interp->vtables[type_id];
        goto NEXT();
    }
    else {
        opcode_t *handler =  Parrot_ex_throw_from_op_args(interp, NULL,
            EXCEPTION_INVALID_OPERATION, "Can only transform an Object to p6opaque");
        goto ADDRESS(handler);
    }
}


/*

=item deobjectref(out PMC, in PMC)

If $2 is an ObjectRef, then follow the chain of ObjectRef
references until we get to a value of some sort (which could be
a Perl6Scalar).

=cut

*/
inline op deobjectref(out PMC, in PMC) :base_core {
    PMC * ref;
    if (!p6s_id) {
        p6s_id = pmc_type(interp, string_from_literal(interp, "Perl6Scalar"));
        or_id  = pmc_type(interp, string_from_literal(interp, "ObjectRef"));
    }
    ref = $2;
    while (ref->vtable->base_type == or_id)
        ref = VTABLE_get_pmc(interp, ref);
    $1 = ref;
    goto NEXT();
}

/*

=item descalarref(out PMC, in PMC)

If $2 is an ObjectRef or Perl6Scalar, then follow the chain of
ObjectRef/Perl6Scalar references until we get to the real
underlying value.

=cut

*/
inline op descalarref(out PMC, in PMC) :base_core {
    PMC * ref;
    if (!p6s_id) {
        p6s_id = pmc_type(interp, string_from_literal(interp, "Perl6Scalar"));
        or_id  = pmc_type(interp, string_from_literal(interp, "ObjectRef"));
    }
    ref = $2;
    while (ref->vtable->base_type == or_id || ref->vtable->base_type == p6s_id)
        ref = VTABLE_get_pmc(interp, ref);
    $1 = ref;
    goto NEXT();
}

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