Пример #1
0
/* Creates a new type with this HOW as its meta-object. */
static void new_type(PARROT_INTERP, PMC *nci) {
    PMC * unused;
    /* We first create a new HOW instance. */
    PMC *capture = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
    PMC *self    = VTABLE_get_pmc_keyed_int(interp, capture, 0);
    PMC *HOW     = REPR(self)->allocate(interp, STABLE(self));
    
    /* See if we have a representation name; if not default to P6opaque. */
    STRING *repr_name = VTABLE_exists_keyed_str(interp, capture, repr_str) ?
        VTABLE_get_string_keyed_str(interp, capture, repr_str) :
        p6opaque_str;
        
    /* Create a new type object of the desired REPR. (Note that we can't
     * default to KnowHOWREPR here, since it doesn't know how to actually
     * store attributes, it's just for bootstrapping knowhow's. */
    REPROps *repr_to_use = REPR_get_by_name(interp, repr_name);
    PMC     *type_object = repr_to_use->type_object_for(interp, HOW);
    
    /* See if we were given a name; put it into the meta-object if so. */
    STRING *name = VTABLE_exists_keyed_str(interp, capture, name_str) ?
        VTABLE_get_string_keyed_str(interp, capture, name_str) :
        empty_str;
    REPR(HOW)->initialize(interp, STABLE(HOW), OBJECT_BODY(HOW));
    ((KnowHOWREPRInstance *)PMC_data(HOW))->body.name = name;
    PARROT_GC_WRITE_BARRIER(interp, HOW);
    
    /* Set .WHO to an empty hash. */
    STABLE(type_object)->WHO = Parrot_pmc_new(interp, enum_class_Hash);
    PARROT_GC_WRITE_BARRIER(interp, STABLE_PMC(type_object));

    /* Put it into capture to act as return value. */
    unused = Parrot_pcc_build_call_from_c_args(interp, capture, "P", type_object);
}
Пример #2
0
/* Gets the current value for an attribute. */
static PMC * get_attribute_boxed(PARROT_INTERP, STable *st, void *data, PMC *class_handle, STRING *name, INTVAL hint) {
    P6opaqueREPRData *repr_data = (P6opaqueREPRData *)st->REPR_data;
    INTVAL            slot;

    /* Try the slot allocation first. */
    slot = hint >= 0 && !(repr_data->mi) ? hint :
        try_get_slot(interp, repr_data, class_handle, name);
    if (slot >= 0) {
        if (!repr_data->flattened_stables[slot]) {
            PMC *result = get_pmc_at_offset(data, repr_data->attribute_offsets[slot]);
            if (result) {
                return result;
            }
            else {
                /* Maybe we know how to auto-viv it to a container. */
                if (repr_data->auto_viv_values) {
                    PMC *value = repr_data->auto_viv_values[slot];
                    if (value != NULL) {
                        if (IS_CONCRETE(value)) {
                            PMC *cloned = REPR(value)->allocate(interp, STABLE(value));
                            REPR(value)->copy_to(interp, STABLE(value), OBJECT_BODY(value), OBJECT_BODY(cloned));
                            PARROT_GC_WRITE_BARRIER(interp, cloned);
                            set_pmc_at_offset(data, repr_data->attribute_offsets[slot], cloned);
                            return cloned;
                        }
                        else {
                            set_pmc_at_offset(data, repr_data->attribute_offsets[slot], value);
                            return value;
                        }
                    }
                }
                return PMCNULL;
            }
        }
        else {
            /* Need to produce a boxed version of this attribute. */
            STable *st  = repr_data->flattened_stables[slot];
            PMC *result = st->REPR->allocate(interp, st);
            st->REPR->copy_to(interp, st, (char *)data + repr_data->attribute_offsets[slot],
                OBJECT_BODY(result));
            PARROT_GC_WRITE_BARRIER(interp, result);

            return result;
        }
    }
    
    /* Otherwise, complain that the attribute doesn't exist. */
    no_such_attribute(interp, "get", class_handle, name);
}
Пример #3
0
/* Composes the representation. */
static void compose(PARROT_INTERP, STable *st, PMC *repr_info) {
    /* Compute allocation strategy. */
    CStructREPRData *repr_data = (CStructREPRData *) st->REPR_data;
    PMC *attr_info = VTABLE_get_pmc_keyed_str(interp, repr_info,
            Parrot_str_new_constant(interp, "attribute"));
    compute_allocation_strategy(interp, attr_info, repr_data);
    PARROT_GC_WRITE_BARRIER(interp, st->stable_pmc);
}
Пример #4
0
/* Gets the hint for the given attribute ID. */
static INTVAL hint_for(PARROT_INTERP, STable *st, PMC *class_key, STRING *name) {
    INTVAL slot;
    P6opaqueREPRData *repr_data = (P6opaqueREPRData *)st->REPR_data;
    if (!repr_data->allocation_size) {
        compute_allocation_strategy(interp, st->WHAT, repr_data);
        PARROT_GC_WRITE_BARRIER(interp, st->stable_pmc);
    }
    slot = try_get_slot(interp, repr_data, class_key, name);
    return slot >= 0 ? slot : NO_HINT;
}
Пример #5
0
/* Serializes the REPR data. */
static void serialize_repr_data(PARROT_INTERP, STable *st, SerializationWriter *writer) {
    P6opaqueREPRData *repr_data = (P6opaqueREPRData *)st->REPR_data;
    INTVAL i, num_classes;
    
    if (!repr_data->allocation_size) {
        compute_allocation_strategy(interp, st->WHAT, repr_data);
        PARROT_GC_WRITE_BARRIER(interp, st->stable_pmc);
    }
    
    writer->write_int(interp, writer, repr_data->num_attributes);

    for (i = 0; i < repr_data->num_attributes; i++) {
        writer->write_int(interp, writer, repr_data->flattened_stables[i] != NULL);
        if (repr_data->flattened_stables[i])
            writer->write_stable_ref(interp, writer, repr_data->flattened_stables[i]);
    }
    
    writer->write_int(interp, writer, repr_data->mi);
    
    if (repr_data->auto_viv_values) {
        writer->write_int(interp, writer, 1);
        for (i = 0; i < repr_data->num_attributes; i++)
            writer->write_ref(interp, writer, repr_data->auto_viv_values[i]);
    }
    else {
        writer->write_int(interp, writer, 0);
    }
    
    writer->write_int(interp, writer, repr_data->unbox_int_slot);
    writer->write_int(interp, writer, repr_data->unbox_num_slot);
    writer->write_int(interp, writer, repr_data->unbox_str_slot);
    
    if (repr_data->unbox_slots) {
        writer->write_int(interp, writer, 1);
        for (i = 0; i < repr_data->num_attributes; i++) {
            writer->write_int(interp, writer, repr_data->unbox_slots[i].repr_id);
            writer->write_int(interp, writer, repr_data->unbox_slots[i].slot);
        }
    }
    else {
        writer->write_int(interp, writer, 0);
    }
    
    num_classes = i = 0;
    while (repr_data->name_to_index_mapping[i].class_key)
        num_classes++, i++;
    writer->write_int(interp, writer, num_classes);
    for (i = 0; i < num_classes; i++) {
        writer->write_ref(interp, writer, repr_data->name_to_index_mapping[i].class_key);
        writer->write_ref(interp, writer, repr_data->name_to_index_mapping[i].name_map);
    }
}
Пример #6
0
/* Gets the current value for an attribute. */
static PMC * get_attribute_boxed(PARROT_INTERP, STable *st, void *data, PMC *class_handle, STRING *name, INTVAL hint) {
    CStructREPRData *repr_data = (CStructREPRData *)st->REPR_data;
    CStructBody     *body      = (CStructBody *)data;
    INTVAL           slot;

    /* Look up slot, then offset and compute address. */
    slot = hint >= 0 ? hint :
        try_get_slot(interp, repr_data, class_handle, name);
    if (slot >= 0) {
        INTVAL type      = repr_data->attribute_locations[slot] & CSTRUCT_ATTR_MASK;
        INTVAL real_slot = repr_data->attribute_locations[slot] >> CSTRUCT_ATTR_SHIFT;

        if(type == CSTRUCT_ATTR_IN_STRUCT)
            Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                    "CStruct Can't perform boxed get on flattened attributes yet");
        else {
            PMC *obj = body->child_objs[real_slot];
            PMC *typeobj = repr_data->member_types[slot];

            if(!obj) {
                void *cobj = get_ptr_at_offset(body->cstruct, repr_data->struct_offsets[slot]);
                if(cobj) {
                    if(type == CSTRUCT_ATTR_CARRAY) {
                        obj = make_carray_result(interp, typeobj, cobj);
                    }
                    else if(type == CSTRUCT_ATTR_CSTRUCT) {
                        obj = make_cstruct_result(interp, typeobj, cobj);
                    }
                    else if(type == CSTRUCT_ATTR_CPTR) {
                        obj = make_cpointer_result(interp, typeobj, cobj);
                    }
                    else if(type == CSTRUCT_ATTR_STRING) {
                        char *cstr = (char *) cobj;
                        STRING *str  = Parrot_str_new_init(interp, cstr, strlen(cstr), Parrot_utf8_encoding_ptr, 0);

                        obj  = REPR(typeobj)->allocate(interp, STABLE(typeobj));
                        REPR(obj)->initialize(interp, STABLE(obj), OBJECT_BODY(obj));
                        REPR(obj)->box_funcs->set_str(interp, STABLE(obj), OBJECT_BODY(obj), str);
                        PARROT_GC_WRITE_BARRIER(interp, obj);
                    }

                    body->child_objs[real_slot] = obj;
                }
                else {
                    obj = typeobj;
                }
            }
            return obj;
        }
    }
Пример #7
0
/* Creates a new type object of this representation, and associates it with
 * the given HOW. */
static PMC * type_object_for(PARROT_INTERP, PMC *HOW) {
    /* Create new type object instance. */
    UninstantiableInstance *obj = mem_allocate_zeroed_typed(UninstantiableInstance);

    /* Build an STable. */
    PMC *st_pmc = create_stable(interp, this_repr, HOW);
    STable *st  = STABLE_STRUCT(st_pmc);

    /* Create type object and point it back at the STable. */
    obj->common.stable = st_pmc;
    st->WHAT = wrap_object(interp, obj);
    PARROT_GC_WRITE_BARRIER(interp, st_pmc);

    return st->WHAT;
}
Пример #8
0
/* Creates a new type object of this representation, and associates it with
 * the given HOW. */
static PMC * type_object_for(PARROT_INTERP, PMC *HOW) {
    /* Create new object instance. */
    HashAttrStoreInstance *obj = mem_allocate_zeroed_typed(HashAttrStoreInstance);

    /* Build an STable. */
    PMC *st_pmc = create_stable(interp, this_repr, HOW);
    STable *st  = STABLE_STRUCT(st_pmc);

    /* Create type object and point it back at the STable. We leave the
     * hash store pointer null to flag it's the type object. */
    obj->common.stable = st_pmc;
    st->WHAT = wrap_object(interp, obj);
    PARROT_GC_WRITE_BARRIER(interp, st_pmc);

    return st->WHAT;
}
Пример #9
0
/* Creates a new instance based on the type object. */
static PMC * allocate(PARROT_INTERP, STable *st) {
    P6opaqueInstance * obj;

    /* Compute allocation strategy if we've not already done so. */
    P6opaqueREPRData * repr_data = (P6opaqueREPRData *) st->REPR_data;
    if (!repr_data->allocation_size) {
        compute_allocation_strategy(interp, st->WHAT, repr_data);
        PARROT_GC_WRITE_BARRIER(interp, st->stable_pmc);
    }

    /* Allocate and set up object instance. */
    obj = (P6opaqueInstance *) Parrot_gc_allocate_fixed_size_storage(interp, repr_data->allocation_size);
    memset(obj, 0, repr_data->allocation_size);
    obj->common.stable = st->stable_pmc;

    return wrap_object(interp, obj);
}
Пример #10
0
/* Creates a new type object of this representation, and associates it with
 * the given HOW. */
static PMC * type_object_for(PARROT_INTERP, PMC *HOW) {
    /* Create new object instance. */
    P6bigintInstance *obj = mem_allocate_zeroed_typed(P6bigintInstance);

    /* Build an STable. */
    PMC *st_pmc = create_stable_func(interp, this_repr, HOW);
    STable *st  = STABLE_STRUCT(st_pmc);

    /* Create type object and point it back at the STable. */
    obj->common.stable = st_pmc;
    st->WHAT = wrap_object_func(interp, obj);
    PARROT_GC_WRITE_BARRIER(interp, st_pmc);

    /* Flag it as a type object. */
    MARK_AS_TYPE_OBJECT(st->WHAT);

    return st->WHAT;
}
Пример #11
0
Файл: P6opaque.c Проект: ruz/nqp
/* Creates a new type object of this representation, and associates it with
 * the given HOW. */
static PMC * type_object_for(PARROT_INTERP, PMC *HOW) {
    /* Create new object instance. */
    P6opaqueInstance *obj = mem_allocate_zeroed_typed(P6opaqueInstance);

    /* Build an STable. */
    PMC *st_pmc = create_stable(interp, this_repr, HOW);
    STable *st  = STABLE_STRUCT(st_pmc);
    
    /* Create REPR data structure and hand it off the STable. */
    st->REPR_data = mem_allocate_zeroed_typed(P6opaqueREPRData);

    /* Create type object and point it back at the STable. Note that we
     * do *not* populate the spill pointer at all, we leave it null. A
     * non-null value (even PMCNULL) is what indicates we have a defined
     * object. Yes, I know, it's sick. */
    obj->common.stable = st_pmc;
    st->WHAT = wrap_object(interp, obj);
    PARROT_GC_WRITE_BARRIER(interp, st_pmc);

    return st->WHAT;
}
Пример #12
0
Файл: P6opaque.c Проект: ruz/nqp
/* Creates a new instance based on the type object. */
static PMC * instance_of(PARROT_INTERP, PMC *WHAT) {
    P6opaqueInstance * obj;

    /* Compute allocation strategy if we've not already done so. */
    P6opaqueREPRData * repr_data = (P6opaqueREPRData *) STABLE(WHAT)->REPR_data;
    if (!repr_data->allocation_size) {
        compute_allocation_strategy(interp, WHAT, repr_data);
        PARROT_GC_WRITE_BARRIER(interp, STABLE_PMC(WHAT));
    }

    /* Allocate and set up object instance. */
    obj = (P6opaqueInstance *) Parrot_gc_allocate_fixed_size_storage(interp, repr_data->allocation_size);
    memset(obj, 0, repr_data->allocation_size);
    obj->common.stable = STABLE_PMC(WHAT);

    /* The spill slot gets set to PMCNULL; it not being (C) NULL is what
     * lets us know it's actually a real instance, not a type object. */
    obj->spill = PMCNULL;
    
    return wrap_object(interp, obj);
}
Пример #13
0
/* Creates a new type object of this representation, and associates it with
 * the given HOW. */
static PMC *type_object_for(PARROT_INTERP, PMC *HOW) {
    /* Create new object instance. */
    CStrInstance *obj = mem_allocate_zeroed_typed(CStrInstance);

    /* Build an STable. */
    PMC *st_pmc = create_stable_func(interp, this_repr, HOW);
    STable *st  = STABLE_STRUCT(st_pmc);
    
    /* Create REPR data structure and hang it off the STable. */
    /* Don't need any REPR data yet. */
    /*st->REPR_data = mem_allocate_zeroed_typed(CStrREPRData);*/

    /* Create type object and point it back at the STable. */
    obj->common.stable = st_pmc;
    st->WHAT = wrap_object_func(interp, obj);
    PARROT_GC_WRITE_BARRIER(interp, st_pmc);

    /* Flag it as a type object. */
    MARK_AS_TYPE_OBJECT(st->WHAT);

    return st->WHAT;
}
Пример #14
0
/* Gets (creating if needed) a multi-dispatch cache. */
static NQP_md_cache *get_dispatch_cache(PARROT_INTERP, PMC *dispatcher) {
    PMC *cache_ptr;
    if (!smo_id)
        smo_id = Parrot_pmc_get_type_str(interp, Parrot_str_new(interp, "SixModelObject", 0));
    if (dispatcher->vtable->base_type == enum_class_Sub && PARROT_SUB(dispatcher)->multi_signature->vtable->base_type == smo_id) {
        NQP_Routine *r = (NQP_Routine *)PMC_data(PARROT_SUB(dispatcher)->multi_signature);
        if (PMC_IS_NULL(r->dispatch_cache)) {
            NQP_md_cache *c = mem_sys_allocate_zeroed(sizeof(NQP_md_cache));
            cache_ptr = Parrot_pmc_new(interp, enum_class_Pointer);
            VTABLE_set_pointer(interp, cache_ptr, c);
            r->dispatch_cache = cache_ptr;
            PARROT_GC_WRITE_BARRIER(interp, PARROT_SUB(dispatcher)->multi_signature);
        }
        else {
            cache_ptr = r->dispatch_cache;
        }
    }
    else {
        Parrot_ex_throw_from_c_args(interp, 0, 1,
            "Could not find multi-dispatch list");
    }
    return (NQP_md_cache *)VTABLE_get_pointer(interp, cache_ptr);
}
Пример #15
0
Файл: P6num.c Проект: TiMBuS/nqp
/* Creates a new type object of this representation, and associates it with
 * the given HOW. */
static PMC * type_object_for(PARROT_INTERP, PMC *HOW) {
    /* Create new object instance. */
    P6numInstance *obj = mem_allocate_zeroed_typed(P6numInstance);
    P6numREPRData *repr_data = mem_allocate_zeroed_typed(P6numREPRData);

    /* Build an STable. */
    PMC *st_pmc = create_stable(interp, this_repr, HOW);
    STable *st  = STABLE_STRUCT(st_pmc);

    /* Set default bit width value in the REPR data and attach it to the
     * STable. */
    repr_data->bits = sizeof(FLOATVAL)*8;
    st->REPR_data = repr_data;

    /* Create type object and point it back at the STable. */
    obj->common.stable = st_pmc;
    st->WHAT = wrap_object(interp, obj);
    PARROT_GC_WRITE_BARRIER(interp, st_pmc);

    /* Flag it as a type object. */
    MARK_AS_TYPE_OBJECT(st->WHAT);

    return st->WHAT;
}
Пример #16
0
/* Serializes the data. */
static void serialize(PARROT_INTERP, STable *st, void *data, SerializationWriter *writer) {
    P6opaqueREPRData *repr_data = (P6opaqueREPRData *)st->REPR_data;
    INTVAL num_attributes, i;
    
    if (!repr_data->allocation_size) {
        compute_allocation_strategy(interp, st->WHAT, repr_data);
        PARROT_GC_WRITE_BARRIER(interp, st->stable_pmc);
    }
    
    num_attributes = repr_data->num_attributes;
    for (i = 0; i < num_attributes; i++) {
        INTVAL a_offset = repr_data->attribute_offsets[i];
        STable *a_st = repr_data->flattened_stables[i];
        if (a_st) {
            if (a_st->REPR->serialize)
                a_st->REPR->serialize(interp, a_st, (char *)data + a_offset, writer);
            else
                Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                    "Missing serialize REPR function");
        }
        else
            writer->write_ref(interp, writer, get_pmc_at_offset(data, a_offset));
    }
}
Пример #17
0
/* Takes a signature along with positional and named arguments and binds them
 * into the provided lexpad (actually, anything that has a Hash interface will
 * do). Returns BIND_RESULT_OK if binding works out, BIND_RESULT_FAIL if there
 * is a failure and BIND_RESULT_JUNCTION if the failure was because of a
 * Junction being passed (meaning we need to auto-thread). */
INTVAL
Rakudo_binding_bind(PARROT_INTERP, PMC *lexpad, PMC *sig_pmc, PMC *capture,
                    INTVAL no_nom_type_check, STRING **error) {
    INTVAL            i, num_pos_args;
    INTVAL            bind_fail   = 0;
    INTVAL            cur_pos_arg = 0;
    Rakudo_Signature *sig         = (Rakudo_Signature *)PMC_data(sig_pmc);
    PMC              *params      = sig->params;
    INTVAL            num_params  = VTABLE_elements(interp, params);
    Rakudo_BindVal    cur_bv;

    /* If we do have some named args, we want to make a clone of the hash
     * to work on. We'll delete stuff from it as we bind, and what we have
     * left over can become the slurpy hash or - if we aren't meant to be
     * taking one - tell us we have a problem. */
    PMC *named_args_copy = PMCNULL;

    /* If we have a |$foo that's followed by slurpies, then we can suppress
     * any future arity checks. */
    INTVAL suppress_arity_fail = 0;
    
    /* If it's a Parrot capture, it may contain natively typed arguments.
     * NOTE: This is a really an encapsulation breakage; if Parrot folks
     * change stuff and this breaks, it's not Parrot's fault. */
    struct Pcc_cell * pc_positionals = NULL;

    /* Set up statics. */
    if (!smo_id)
        setup_binder_statics(interp);

    /* If we've got a CallContext, just has an attribute with list of named
     * parameter names. Otherwise, it's probably a Perl 6 Capture and we need
     * to extract its parts. */
    if (capture->vtable->base_type == enum_class_CallContext) {
        PMC *named_names = VTABLE_get_attr_str(interp, capture, NAMED_str);
        if (!PMC_IS_NULL(named_names)) {
            PMC *iter = VTABLE_get_iter(interp, named_names);
            named_args_copy = Parrot_pmc_new(interp, enum_class_Hash);
            while (VTABLE_get_bool(interp, iter)) {
                STRING *name = VTABLE_shift_string(interp, iter);
                VTABLE_set_pmc_keyed_str(interp, named_args_copy, name,
                        VTABLE_get_pmc_keyed_str(interp, capture, name));
            }
        }
        GETATTR_CallContext_positionals(interp, capture, pc_positionals);
    }
    else if (capture->vtable->base_type == smo_id &&
            STABLE(capture)->type_check(interp, capture, Rakudo_types_capture_get())) {
        PMC *captype   = Rakudo_types_capture_get();
        PMC *list_part = VTABLE_get_attr_keyed(interp, capture, captype, LIST_str);
        PMC *hash_part = VTABLE_get_attr_keyed(interp, capture, captype, HASH_str);
        capture = Rakudo_isnqplist(list_part) 
                    ?  list_part 
                    : Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
        if (hash_part->vtable->base_type == enum_class_Hash) {
            PMC *iter = VTABLE_get_iter(interp, hash_part);
            named_args_copy = Parrot_pmc_new(interp, enum_class_Hash);
            while (VTABLE_get_bool(interp, iter)) {
                STRING *arg_copy_name = VTABLE_shift_string(interp, iter);
                VTABLE_set_pmc_keyed_str(interp, named_args_copy, arg_copy_name,
                    VTABLE_get_pmc_keyed_str(interp, hash_part, arg_copy_name));
            }
        }
    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                "Internal Error: Rakudo_binding_bind passed invalid Capture");
    }

    /* Now we'll walk through the signature and go about binding things. */
    num_pos_args = VTABLE_elements(interp, capture);
    for (i = 0; i < num_params; i++) {
        Rakudo_Parameter *param = (Rakudo_Parameter *)PMC_data(
                VTABLE_get_pmc_keyed_int(interp, params, i));

        /* Is it looking for us to bind a capture here? */
        if (param->flags & SIG_ELEM_IS_CAPTURE) {
            /* Capture the arguments from this point forwards into a Capture.
             * Of course, if there's no variable name we can (cheaply) do pretty
             * much nothing. */
            if (STRING_IS_NULL(param->variable_name)) {
                bind_fail = BIND_RESULT_OK;
            }
            else {
                PMC *captype    = Rakudo_types_capture_get();
                PMC *capsnap    = REPR(captype)->allocate(interp, STABLE(captype));
                PMC *pos_args   = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
                PMC *named_args = Parrot_pmc_new(interp, enum_class_Hash);
                INTVAL k;
                VTABLE_set_attr_keyed(interp, capsnap, captype, LIST_str, pos_args);
                VTABLE_set_attr_keyed(interp, capsnap, captype, HASH_str, named_args);
                for (k = cur_pos_arg; k < num_pos_args; k++) {
                    cur_bv = get_positional_bind_val(interp, pc_positionals, capture, k);
                    VTABLE_push_pmc(interp, pos_args, cur_bv.type == BIND_VAL_OBJ ?
                        cur_bv.val.o :
                        create_box(interp, cur_bv));
                }
                if (!PMC_IS_NULL(named_args_copy)) {
                    PMC *iter = VTABLE_get_iter(interp, named_args_copy);
                    while (VTABLE_get_bool(interp, iter)) {
                        STRING *name = VTABLE_shift_string(interp, iter);
                        VTABLE_set_pmc_keyed_str(interp, named_args, name,
                            VTABLE_get_pmc_keyed_str(interp, named_args_copy, name));
                    }
                }
                cur_bv.type = BIND_VAL_OBJ;
                cur_bv.val.o = capsnap;
                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param, cur_bv,
                        no_nom_type_check, error);
            }
            if (bind_fail) {
                return bind_fail;
            }
            else if (i + 1 == num_params) {
                /* Since a capture acts as "the ultimate slurpy" in a sense, if
                 * this is the last parameter in the signature we can return
                 * success right off the bat. */
                return BIND_RESULT_OK;
            }
            else {
                Rakudo_Parameter *next_param = (Rakudo_Parameter *)PMC_data(
                    VTABLE_get_pmc_keyed_int(interp, params, i + 1));
                if (next_param->flags & (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_NAMED))
                    suppress_arity_fail = 1;
            }
        }

        /* Could it be a named slurpy? */
        else if (param->flags & SIG_ELEM_SLURPY_NAMED) {
            /* Can cheat a bit if it's the default method %_.
             * We give the hash to the lexpad. */
            if (param->flags & SIG_ELEM_METHOD_SLURPY_NAMED && lexpad->vtable->base_type == p6l_id) {
                SETATTR_Perl6LexPad_default_named_slurpy(interp, lexpad, named_args_copy);
                PARROT_GC_WRITE_BARRIER(interp, lexpad);
            }
            else {
                /* We'll either take the current named arguments copy hash which
                 * will by definition contain all unbound named parameters and use
                 * that, or just create an empty one. */
                PMC *slurpy = PMC_IS_NULL(named_args_copy) ?
                        Parrot_pmc_new(interp, enum_class_Hash) :
                        named_args_copy;
                cur_bv.type = BIND_VAL_OBJ;
                cur_bv.val.o = Rakudo_binding_create_hash(interp, slurpy);
                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                        cur_bv, no_nom_type_check, error);
                if (bind_fail)
                    return bind_fail;
            }
            
            /* Nullify named arguments hash now we've consumed it, to mark all
             * is well. */
            named_args_copy = PMCNULL;
        }

        /* Otherwise, maybe it's a positional. */
        else if (PMC_IS_NULL(param->named_names)) {
            /* Slurpy or LoL-slurpy? */
            if (param->flags & (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_LOL)) {
                /* Create Perl 6 array, create RPA of all remaining things, then
                 * store it. */
                PMC *temp = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
                while (cur_pos_arg < num_pos_args) {
                    cur_bv = get_positional_bind_val(interp, pc_positionals, capture, cur_pos_arg);
                    VTABLE_push_pmc(interp, temp, cur_bv.type == BIND_VAL_OBJ ?
                        cur_bv.val.o :
                        create_box(interp, cur_bv));
                    cur_pos_arg++;
                }
                cur_bv.type = BIND_VAL_OBJ;
                cur_bv.val.o = param->flags & SIG_ELEM_SLURPY_POS ?
                    Rakudo_binding_create_positional(interp, temp) :
                    Rakudo_binding_create_lol(interp, temp);
                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                        cur_bv, no_nom_type_check, error);
                if (bind_fail)
                    return bind_fail;
            }

            /* Otherwise, a positional. */
            else {
                /* Do we have a value?. */
                if (cur_pos_arg < num_pos_args) {
                    /* Easy - just bind that. */
                    cur_bv = get_positional_bind_val(interp, pc_positionals, capture, cur_pos_arg);
                    bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                            cur_bv, no_nom_type_check, error);
                    if (bind_fail)
                        return bind_fail;
                    cur_pos_arg++;
                }
                else {
                    /* No value. If it's optional, fetch a default and bind that;
                     * if not, we're screwed. Note that we never nominal type check
                     * an optional with no value passed. */
                    if (param->flags & SIG_ELEM_IS_OPTIONAL) {
                        cur_bv.type = BIND_VAL_OBJ;
                        cur_bv.val.o = Rakudo_binding_handle_optional(interp, param, lexpad);
                        bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                                cur_bv, 0, error);
                        if (bind_fail)
                            return bind_fail;
                    }
                    else {
                        if (error)
                            *error = Rakudo_binding_arity_fail(interp, params, num_params, num_pos_args, 0);
                        return BIND_RESULT_FAIL;
                    }
                }
            }
        }

        /* Else, it's a non-slurpy named. */
        else {
            /* Try and get hold of value. */
            PMC *value = PMCNULL;
            INTVAL num_names = VTABLE_elements(interp, param->named_names);
            INTVAL j;
            if (!PMC_IS_NULL(named_args_copy)) {
                for (j = 0; j < num_names; j++) {
                    STRING *name = VTABLE_get_string_keyed_int(interp, param->named_names, j);
                    value = VTABLE_get_pmc_keyed_str(interp, named_args_copy, name);
                    if (!PMC_IS_NULL(value)) {
                        /* Found a value. Delete entry from to-bind args and stop looking. */
                        VTABLE_delete_keyed_str(interp, named_args_copy, name);
                        break;
                    }
                }
            }

            /* Did we get one? */
            if (PMC_IS_NULL(value)) {
                /* Nope. We'd better hope this param was optional... */
                if (param->flags & SIG_ELEM_IS_OPTIONAL) {
                    cur_bv.type = BIND_VAL_OBJ;
                    cur_bv.val.o = Rakudo_binding_handle_optional(interp, param, lexpad);
                    bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                            cur_bv, 0, error);
                }
                else if (!suppress_arity_fail) {
                    if (error)
                        *error = Parrot_sprintf_c(interp, "Required named parameter '%S' not passed",
                                VTABLE_get_string_keyed_int(interp, param->named_names, 0));
                    return BIND_RESULT_FAIL;
                }
            }
            else {
                cur_bv.type = BIND_VAL_OBJ;
                cur_bv.val.o = value;
                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                        cur_bv, 0, error);
            }

            /* If we got a binding failure, return it. */
            if (bind_fail)
                return bind_fail;
        }
    }

    /* Do we have any left-over args? */
    if (cur_pos_arg < num_pos_args && !suppress_arity_fail) {
        /* Oh noes, too many positionals passed. */
        if (error)
            *error = Rakudo_binding_arity_fail(interp, params, num_params, num_pos_args, 1);
        return BIND_RESULT_FAIL;
    }
    if (!PMC_IS_NULL(named_args_copy) && VTABLE_elements(interp, named_args_copy)) {
        /* Oh noes, unexpected named args. */
        if (error) {
            INTVAL num_extra = VTABLE_elements(interp, named_args_copy);
            PMC *iter        = VTABLE_get_iter(interp, named_args_copy);
            if (num_extra == 1) {
                *error = Parrot_sprintf_c(interp, "Unexpected named parameter '%S' passed",
                        VTABLE_shift_string(interp, iter));
            }
            else {
                INTVAL first  = 1;
                STRING *comma = Parrot_str_new(interp, ", ", 0);
                *error = Parrot_sprintf_c(interp, "%d unexpected named parameters passed (", num_extra);
                while (VTABLE_get_bool(interp, iter)) {
                    STRING *name = VTABLE_shift_string(interp, iter);
                    if (!first)
                        *error = Parrot_str_concat(interp, *error, comma);
                    else
                        first = 0;
                    *error = Parrot_str_concat(interp, *error, name);
                }
                *error = Parrot_str_concat(interp, *error, Parrot_str_new(interp, ")", 0));
            }
        }
        return BIND_RESULT_FAIL;
    }

    /* If we get here, we're done. */
    return BIND_RESULT_OK;
}
Пример #18
0
/* Binds a single argument into the lexpad, after doing any checks that are
 * needed. Also handles any type captures. If there is a sub signature, then
 * re-enters the binder. Returns one of the BIND_RESULT_* codes. */
static INTVAL
Rakudo_binding_bind_one_param(PARROT_INTERP, PMC *lexpad, PMC *llsig, llsig_element *sig_info,
                              PMC *value, INTVAL no_nom_type_check, STRING **error) {
    /* If we need to do a type check, do one. */
    if (!no_nom_type_check) {
        /* See if we get a hit in the type cache. */
        INTVAL cache_matched = 0;
        INTVAL value_type = VTABLE_type(interp, value);
        if (value_type != 0) {
            INTVAL i;
            for (i = 0; i < NOM_TYPE_CACHE_SIZE; i++) {
                if (sig_info->nom_type_cache[i] == value_type)
                {
                    cache_matched = 1;
                    break;
                }
            }
        }
        
        /* If not, do the check. */
        if (!cache_matched) {
            PMC * const type_obj   = sig_info->nominal_type;
            PMC * accepts_meth     = VTABLE_find_method(interp, type_obj, ACCEPTS);
            PMC * result           = PMCNULL;
            Parrot_ext_call(interp, accepts_meth, "PiP->P", type_obj, value, &result);
            if (VTABLE_get_bool(interp, result)) {
                /* Cache if possible. */
                if (value_type != 0 && value_type != p6r_id && value_type != p6o_id) {
                    INTVAL i;
                    for (i = 0; i < NOM_TYPE_CACHE_SIZE; i++) {
                        if (sig_info->nom_type_cache[i] == 0)
                        {
                            sig_info->nom_type_cache[i] = value_type;
                            PARROT_GC_WRITE_BARRIER(interp, llsig);
                            break;
                        }
                    }
                }
            }
            else {
                /* Type check failed. However, for language inter-op, we do some
                 * extra checks if the type is just Positional, Associative, or
                 * Callable and the thingy we have matches those enough. */
                /* XXX TODO: Implement language interop checks. */
                if (error) {
                    STRING * const perl = PERL_str;
                    PMC    * perl_meth  = VTABLE_find_method(interp, type_obj, perl);
                    PMC    * how_meth   = VTABLE_find_method(interp, value, HOW);
                    STRING * expected, * got;
                    PMC    * value_how, * value_type;
                    Parrot_ext_call(interp, perl_meth, "Pi->S", type_obj, &expected);
                    Parrot_ext_call(interp, how_meth, "Pi->P", value, &value_how);
                    value_type = VTABLE_get_attr_str(interp, value_how, SHORTNAME_str);
                    got        = VTABLE_get_string(interp, value_type);
                    *error = Parrot_sprintf_c(interp, "Nominal type check failed for parameter '%S'; expected %S but got %S instead",
                                sig_info->variable_name, expected, got);
                }
                if (VTABLE_isa(interp, value, JUNCTION_str))
                    return BIND_RESULT_JUNCTION;
                else
                    return BIND_RESULT_FAIL;
            }
        }
    }

    /* Do we have any type captures to bind? */
    if (!PMC_IS_NULL(sig_info->type_captures))
        Rakudo_binding_bind_type_captures(interp, lexpad, sig_info, value);

    /* Do a coercion, if one is needed. */
    if (!STRING_IS_NULL(sig_info->coerce_to)) {
        PMC *coerce_meth = VTABLE_find_method(interp, value, sig_info->coerce_to);
        if (!PMC_IS_NULL(coerce_meth)) {
            Parrot_ext_call(interp, coerce_meth, "Pi->P", value, &value);
        }
        else {
            /* No coercion method availale; whine and fail to bind. */
            if (error) {
                PMC    * how_meth   = VTABLE_find_method(interp, value, HOW);
                PMC    * value_how, * value_type;
                STRING * got;
                Parrot_ext_call(interp, how_meth, "Pi->P", value, &value_how);
                value_type = VTABLE_get_attr_str(interp, value_how, SHORTNAME_str);
                got        = VTABLE_get_string(interp, value_type);
                *error = Parrot_sprintf_c(interp,
                        "Unable to coerce value for '%S' from %S to %S; no coercion method defined",
                        sig_info->variable_name, got, sig_info->coerce_to);
            }
            return BIND_RESULT_FAIL;
        }
    }

    /* If it's not got attributive binding, we'll go about binding it into the
     * lex pad. */
    if (!(sig_info->flags & SIG_ELEM_BIND_ATTRIBUTIVE)) {
        /* Is it "is rw"? */
        if (sig_info->flags & SIG_ELEM_IS_RW) {
            /* XXX TODO Check if rw flag is set. */
            if (!STRING_IS_NULL(sig_info->variable_name))
                VTABLE_set_pmc_keyed_str(interp, lexpad, sig_info->variable_name, value);
        }
        else if (sig_info->flags & SIG_ELEM_IS_PARCEL) {
            /* Just bind the thing as is into the lexpad. */
            if (!STRING_IS_NULL(sig_info->variable_name))
                VTABLE_set_pmc_keyed_str(interp, lexpad, sig_info->variable_name, value);
        }
        else if (sig_info->flags & SIG_ELEM_IS_COPY) {
            /* Place the value into a new container instead of binding to an existing one */
            value = descalarref(interp, value);
            if (!STRING_IS_NULL(sig_info->variable_name)) {
                PMC *copy, *ref, *store_meth;
                if (sig_info->flags & SIG_ELEM_ARRAY_SIGIL) {
                    copy          = Rakudo_binding_create_positional(interp, PMCNULL, ARRAY_str);
                    store_meth    = VTABLE_find_method(interp, copy, STORE_str);
                    Parrot_ext_call(interp, store_meth, "PiP", copy, value);
                }
                else if (sig_info->flags & SIG_ELEM_HASH_SIGIL) {
                    copy          = Rakudo_binding_create_hash(interp, pmc_new(interp, enum_class_Hash));
                    store_meth    = VTABLE_find_method(interp, copy, STORE_str);
                    Parrot_ext_call(interp, store_meth, "PiP", copy, value);
                }
                else {
                    copy = pmc_new_init(interp, p6s_id, value);
                    VTABLE_setprop(interp, copy, SCALAR_str, copy);
                }
                VTABLE_setprop(interp, copy, RW_str, copy);
                VTABLE_set_pmc_keyed_str(interp, lexpad, sig_info->variable_name, copy);
            }
        }
        else {
            /* Read only. Wrap it into a ObjectRef, mark readonly and bind it. */
            if (!STRING_IS_NULL(sig_info->variable_name)) {
                PMC *ref  = pmc_new_init(interp, or_id, value);
                if (!(sig_info->flags & (SIG_ELEM_ARRAY_SIGIL | SIG_ELEM_HASH_SIGIL)))
                    VTABLE_setprop(interp, ref, SCALAR_str, ref);
                VTABLE_set_pmc_keyed_str(interp, lexpad, sig_info->variable_name, ref);
            }
        }
    }

    /* Is it the invocant? If so, also have to bind to self lexical. */
    if (sig_info->flags & SIG_ELEM_INVOCANT)
        VTABLE_set_pmc_keyed_str(interp, lexpad, SELF_str, value);

    /* Handle any constraint types (note that they may refer to the parameter by
     * name, so we need to have bound it already). */
    if (!PMC_IS_NULL(sig_info->post_constraints)) {
        PMC * const constraints = sig_info->post_constraints;
        INTVAL num_constraints  = VTABLE_elements(interp, constraints);
        PMC * result            = PMCNULL;
        INTVAL i;
        for (i = 0; i < num_constraints; i++) {
            PMC *cons_type    = VTABLE_get_pmc_keyed_int(interp, constraints, i);
            PMC *accepts_meth = VTABLE_find_method(interp, cons_type, ACCEPTS);
            if (VTABLE_isa(interp, cons_type, BLOCK_str))
                Parrot_sub_capture_lex(interp,
                    VTABLE_get_attr_str(interp, cons_type, DO_str));
            Parrot_ext_call(interp, accepts_meth, "PiP->P", cons_type, value, &result);
            if (!VTABLE_get_bool(interp, result)) {
                if (error)
                    *error = Parrot_sprintf_c(interp, "Constraint type check failed for parameter '%S'",
                            sig_info->variable_name);
                return BIND_RESULT_FAIL;
            }
        }
    }

    /* If it's attributive, now we assign it. */
    if (sig_info->flags & SIG_ELEM_BIND_ATTRIBUTIVE) {
        INTVAL result = Rakudo_binding_assign_attributive(interp, lexpad, sig_info, value, error);
        if (result != BIND_RESULT_OK)
            return result;
    }

    /* If it has a sub-signature, bind that. */
    if (!PMC_IS_NULL(sig_info->sub_llsig)) {
        /* Turn value into a capture, unless we already have one. */
        PMC *capture = PMCNULL;
        INTVAL result;
        if (sig_info->flags & SIG_ELEM_IS_CAPTURE) {
            capture = value;
        }
        else {
            PMC *meth    = VTABLE_find_method(interp, value, Parrot_str_new(interp, "Capture", 0));
            if (PMC_IS_NULL(meth)) {
                if (error)
                    *error = Parrot_sprintf_c(interp, "Could not turn argument into capture");
                return BIND_RESULT_FAIL;
            }
            Parrot_ext_call(interp, meth, "Pi->P", value, &capture);
        }

        /* Recurse into signature binder. */
        result = Rakudo_binding_bind_llsig(interp, lexpad, sig_info->sub_llsig,
                capture, no_nom_type_check, error);
        if (result != BIND_RESULT_OK)
        {
            if (error) {
                /* Note in the error message that we're in a sub-signature. */
                *error = Parrot_str_concat(interp, *error,
                        Parrot_str_new(interp, " in sub-signature", 0));

                /* Have we a variable name? */
                if (!STRING_IS_NULL(sig_info->variable_name)) {
                    *error = Parrot_str_concat(interp, *error,
                            Parrot_str_new(interp, " of parameter ", 0));
                    *error = Parrot_str_concat(interp, *error, sig_info->variable_name);
                }
            }
            return result;
        }
    }

    /* Binding of this parameter was thus successful - we're done. */
    return BIND_RESULT_OK;
}
Пример #19
0
/* Takes a signature along with positional and named arguments and binds them
 * into the provided lexpad (actually, anything that has a Hash interface will
 * do). Returns BIND_RESULT_OK if binding works out, BIND_RESULT_FAIL if there
 * is a failure and BIND_RESULT_JUNCTION if the failure was because of a
 * Junction being passed (meaning we need to auto-thread). */
INTVAL
Rakudo_binding_bind_llsig(PARROT_INTERP, PMC *lexpad, PMC *llsig,
                              PMC *capture, INTVAL no_nom_type_check,
                              STRING **error) {
    INTVAL        i;
    INTVAL        bind_fail;
    INTVAL        cur_pos_arg  = 0;
    INTVAL        num_pos_args = VTABLE_elements(interp, capture);
    PMC           *named_names = PMCNULL;
    llsig_element **elements;
    INTVAL        num_elements;
    PMC           *named_to_pos_cache;

    /* Lazily allocated array of bindings to positionals of nameds. */
    PMC **pos_from_named = NULL;

    /* If we do have some named args, we want to make a clone of the hash
     * to work on. We'll delete stuff from it as we bind, and what we have
     * left over can become the slurpy hash or - if we aren't meant to be
     * taking one - tell us we have a problem. */
    PMC *named_args_copy = PMCNULL;

    /* If we have a |$foo that's followed by slurpies, then we can suppress
     * any future arity checks. */
    INTVAL suppress_arity_fail = 0;

    /* Check that we have a valid signature and pull the bits out of it. */
    if (!lls_id)
        setup_binder_statics(interp);

    if (llsig->vtable->base_type != lls_id)
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                "Internal Error: Rakudo_binding_bind_llsig passed invalid signature");

    GETATTR_P6LowLevelSig_elements(interp, llsig, elements);
    GETATTR_P6LowLevelSig_num_elements(interp, llsig, num_elements);
    GETATTR_P6LowLevelSig_named_to_pos_cache(interp, llsig, named_to_pos_cache);

    /* Build nameds -> position hash for named positional arguments,
     * if it was not yet built. */
    if (PMC_IS_NULL(named_to_pos_cache)) {
        named_to_pos_cache = pmc_new(interp, enum_class_Hash);
        PARROT_GC_WRITE_BARRIER(interp, llsig);
        SETATTR_P6LowLevelSig_named_to_pos_cache(interp, llsig, named_to_pos_cache);
        for (i = 0; i < num_elements; i++) {
            /* If we find a named argument, we're done with the positionals. */
            if (!PMC_IS_NULL(elements[i]->named_names))
                break;

            /* Skip slurpies (may be a slurpy block, so can't just break). */
            if (elements[i]->flags & SIG_ELEM_SLURPY)
                continue;

            /* Provided it has a name... */
            if (!STRING_IS_NULL(elements[i]->variable_name)) {
                /* Strip any sigil, then stick in named to positional array. */
                STRING *store  = elements[i]->variable_name;
                STRING *sigil  = Parrot_str_substr(interp, store, 0, 1);
                STRING *twigil = Parrot_str_substr(interp, store, 1, 1);

                if (Parrot_str_equal(interp, sigil, SCALAR_SIGIL_str)
                ||  Parrot_str_equal(interp, sigil, ARRAY_SIGIL_str)
                ||  Parrot_str_equal(interp, sigil, HASH_SIGIL_str))
                    store = Parrot_str_substr(interp, store, 1,
                            Parrot_str_byte_length(interp, store));

                if (Parrot_str_equal(interp, twigil, BANG_TWIGIL_str))
                    store = Parrot_str_substr(interp, store, 1,
                            Parrot_str_byte_length(interp, store));

                VTABLE_set_integer_keyed_str(interp, named_to_pos_cache, store, i);
            }
        }
    }

    /* If we've got a CallContext, just has an attribute with list of named
     * parameter names. Otherwise, it's a Capture and we need to do .hash and
     * grab out the keys. */
    if (capture->vtable->base_type == enum_class_CallContext
    ||  VTABLE_isa(interp, capture, CALLCONTEXT_str)) {
        named_names = VTABLE_get_attr_str(interp, capture, Parrot_str_new(interp, "named", 0));
    }
    else if (VTABLE_isa(interp, capture, CAPTURE_str)) {
        PMC *meth = VTABLE_find_method(interp, capture, Parrot_str_new(interp, "!PARROT_NAMEDS", 0));
        PMC *hash = PMCNULL;
        PMC *iter;
        Parrot_ext_call(interp, meth, "Pi->P", capture, &hash);
        iter = VTABLE_get_iter(interp, hash);
        if (VTABLE_get_bool(interp, iter)) {
            named_names = pmc_new(interp, enum_class_ResizableStringArray);
            while (VTABLE_get_bool(interp, iter))
                VTABLE_push_string(interp, named_names, VTABLE_shift_string(interp, iter));
        }
    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                "Internal Error: Rakudo_binding_bind_llsig passed invalid Capture");
    }

    /* First, consider named arguments, to see if there are any that we will
     * be wanting to bind positionally. */
    if (!PMC_IS_NULL(named_names)) {
        PMC *iter = VTABLE_get_iter(interp, named_names);
        named_args_copy = pmc_new(interp, enum_class_Hash);
        while (VTABLE_get_bool(interp, iter)) {
            STRING *name = VTABLE_shift_string(interp, iter);
            if (VTABLE_exists_keyed_str(interp, named_to_pos_cache, name)) {
                /* Found one. We'll stash it away for quick access to bind it
                 * later. */
                INTVAL pos = VTABLE_get_integer_keyed_str(interp, named_to_pos_cache, name);
                if (!pos_from_named)
                    pos_from_named = mem_allocate_n_zeroed_typed(num_elements, PMC *);
                pos_from_named[pos] = VTABLE_get_pmc_keyed_str(interp, capture, name);
            }
            else {
                /* Otherwise, we'll enter it into the hash of things to bind
                 * to nameds. */
                VTABLE_set_pmc_keyed_str(interp, named_args_copy, name,
                        VTABLE_get_pmc_keyed_str(interp, capture, name));
            }
        }
Пример #20
0
/* Performs a change of type, where possible. */
static void change_type(PARROT_INTERP, PMC *obj, PMC *new_type) {
    P6opaqueInstance *instance      = (P6opaqueInstance *)PMC_data(obj);
    P6opaqueREPRData *cur_repr_data = (P6opaqueREPRData *)STABLE(obj)->REPR_data;
    P6opaqueREPRData *new_repr_data = (P6opaqueREPRData *)STABLE(new_type)->REPR_data;
    STRING           *mro_str       = Parrot_str_new_constant(interp, "mro");
    PMC              *cur_mro, *new_mro;
    INTVAL            cur_mro_elems, new_mro_elems, mro_is_suffix;
    
    /* Ensure we're not trying to change the type of a type object. */
    if (PObj_flag_TEST(private0, obj))
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Cannot change the type of a type object");
    
    /* Ensure that the destination type REPR is P6opaque also. */
    if (REPR(obj) != REPR(new_type))
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "P6opaque can only change type to another type with P6opaque REPR");

    /* Ensure that MRO of new type has current type's MRO as a suffix. */
    mro_is_suffix = 1;
    cur_mro = introspection_call(interp, STABLE(obj)->WHAT, STABLE(obj)->HOW, mro_str, 0);
    new_mro = introspection_call(interp, STABLE(new_type)->WHAT, STABLE(new_type)->HOW, mro_str, 0);
    cur_mro_elems = VTABLE_elements(interp, cur_mro);
    new_mro_elems = VTABLE_elements(interp, new_mro);
    if (new_mro_elems >= cur_mro_elems) {
        INTVAL start = new_mro_elems - cur_mro_elems;
        INTVAL i;
        for (i = 0; i < cur_mro_elems; i++) {
            PMC *cur_elem = VTABLE_get_pmc_keyed_int(interp, cur_mro, i);
            PMC *new_elem = VTABLE_get_pmc_keyed_int(interp, new_mro, i + start);
            if (decontainerize(interp, cur_elem) != decontainerize(interp, new_elem)) {
                mro_is_suffix = 0;
                break;
            }
        }
    }
    else {
        mro_is_suffix = 0;
    }
    if (!mro_is_suffix)
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "P6opaque only supports type changes where the MRO of the original type is a suffix of the MRO of the new type");
    
    /* If the new REPR never calculated it's object layout, do so now. */
    if (!new_repr_data->allocation_size) {
        compute_allocation_strategy(interp, new_type, new_repr_data);
        PARROT_GC_WRITE_BARRIER(interp, STABLE_PMC(new_type));
    }
    
    /* Reallocate ourself to the new allocation size, if needed, and
     * ensure new chunk of the memory is zeroed. Note that we can't
     * really re-alloc, we need to go deal with the fixed size pool
     * allocator. */
    if (new_repr_data->allocation_size > cur_repr_data->allocation_size) {
        P6opaqueInstance *new_body = (P6opaqueInstance *) Parrot_gc_allocate_fixed_size_storage(interp, new_repr_data->allocation_size);
        memset(new_body, 0, new_repr_data->allocation_size);
        memcpy(new_body, instance, cur_repr_data->allocation_size);
        PMC_data(obj) = new_body;
        Parrot_gc_free_fixed_size_storage(interp, cur_repr_data->allocation_size, instance);
        instance = new_body;
    }
    
    /* Finally, we're ready to switch the S-Table pointer. */
    instance->common.stable = STABLE_PMC(new_type);
    PARROT_GC_WRITE_BARRIER(interp, obj);
}