/*
 * $Id: /mirror/trunk/languages/perl6/src/ops/perl6.ops 32474 2008-11-08T03:21:55.918817Z chromatic  $
 * Copyright (C) 2008, The Perl Foundation.
 */

#include "parrot/dynext.h"
#include "../../../../src/pmc/pmc_object.h"
VERSION = PARROT_VERSION;

inline op rebless_subclass(in PMC, in PMC) :base_core {
    PMC *value;

    /* 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 *current_class = VTABLE_get_class(interp, $1);
    PMC *parent_list = VTABLE_inspect_str(interp, $2, const_string(interp, "all_parents"));
    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 *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, const_string(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, const_string(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 *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 *temp  = mem_allocate_typed(PMC);
        PMC *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));
    }
    else if (value->vtable->base_type != enum_class_Object
            || 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();
}

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