Forget to remove the return after real_exception, as recomended in a
talk in #parrot.
Second revision attached.
--
Salu2
Index: src/oo.c
===================================================================
--- src/oo.c (revisión: 27509)
+++ src/oo.c (copia de trabajo)
@@ -1148,8 +1148,7 @@
=item C<PMC * Parrot_remove_parent>
-This currently does nothing but return C<PMCNULL>.
-RT#50646
+Remove a parent class from a PMC, by invoking his remove_parent method.
=cut
@@ -1162,11 +1161,8 @@
Parrot_remove_parent(PARROT_INTERP, ARGIN(PMC *removed_class),
ARGIN(PMC *existing_class))
{
- UNUSED(interp);
- UNUSED(removed_class);
- UNUSED(existing_class);
-
- return PMCNULL;
+ VTABLE_remove_parent(interp, existing_class, removed_class);
+ return existing_class;
}
Index: src/pmc/class.pmc
===================================================================
--- src/pmc/class.pmc (revisión: 27509)
+++ src/pmc/class.pmc (copia de trabajo)
@@ -780,6 +780,66 @@
/*
+=item C<void remove_parent(PMC *parent)>
+
+Remove the supplied PMC from the list of parents for the class.
+Throws E_TypeError if parent is NULL, is not a class, or is not a parent.
+Throws INVALID_OPERATION if the class has been instantiated.
+
+=cut
+
+*/
+ VTABLE void remove_parent(PMC *parent) {
+ Parrot_Class * const _class = PARROT_CLASS(SELF);
+
+ /* get number of direct parents */
+ const int parent_count = VTABLE_elements(interp, _class->parents);
+
+ int index; /* loop iterator */
+
+ /* If we've been instantiated already, not allowed. */
+ if (_class->instantiated) {
+ real_exception(interp, NULL, INVALID_OPERATION,
+ "Modifications to classes are not allowed after instantiation.");
+ }
+
+ /* Ensure it really is a class. */
+ if (!PObj_is_class_TEST(parent)) {
+ real_exception(interp, NULL, E_TypeError, "Parent isn't a Class.");
+ }
+
+ /* iterate over all direct parents, looking for
+ * the parent to be removed.
+ */
+ for (index = 0; index < parent_count; index++) {
+ /* get the next parent */
+ PMC * const current_parent = VTABLE_get_pmc_keyed_int(interp,
+ _class->parents, index);
+ if (current_parent == parent)
+ break;
+ }
+ if (index >= parent_count)
+ real_exception(interp, NULL, INVALID_OPERATION,
+ "Can't remove_parent: is not a parent.");
+
+ /* Move up the remaining parents on the list and pops it */
+ for (; index < parent_count - 1; index++) {
+ PMC * const current_parent = VTABLE_get_pmc_keyed_int(interp,
+ _class->parents, index + 1);
+ VTABLE_set_pmc_keyed_int(interp, _class->parents,
+ index, current_parent);
+ }
+ VTABLE_pop_pmc(interp, _class->parents);
+
+ _class->all_parents = Parrot_ComputeMRO_C3(interp, SELF);
+
+ /* Anonymous classes have no entry in the vtable array */
+ if (!CLASS_is_anon_TEST(SELF))
+ interp->vtables[VTABLE_type(interp, SELF)]->mro = _class->all_parents;
+ }
+
+/*
+
=item C<void add_role(PMC *role)>
Adds the supplied PMC to the list of roles for the class, provided there are
Index: t/oo/removeparent.t
===================================================================
--- t/oo/removeparent.t (revisión: 0)
+++ t/oo/removeparent.t (revisión: 0)
@@ -0,0 +1,123 @@
+#! parrot
+# Copyright (C) 2008, The Perl Foundation.
+# $Id: $
+
+=head1 NAME
+
+t/oo/removeparent.t - Test OO inheritance
+
+=head1 SYNOPSIS
+
+ % prove t/oo/removeparent.t
+
+=head1 DESCRIPTION
+
+Tests OO features related to the removeparent opcode.
+
+=cut
+
+.sub main :main
+ .include 'include/test_more.pir'
+
+ plan(4)
+
+ remove_1()
+ remove_2()
+ remove_Y()
+ remove_diamond()
+.end
+
+.sub remove_1
+ $P1 = newclass "Foo"
+ $P2 = newclass "Bar"
+ $I1 = isa $P2, $P1
+ if $I1, fail
+ addparent $P2, $P1
+ $I1 = isa $P2, $P1
+ unless $I1, fail
+ removeparent $P2, $P1
+ $I1 = isa $P2, $P1
+ if $I1, fail
+ $I1 = 1
+ ok( $I1, 'simple')
+fail:
+.end
+
+.sub remove_2
+ $P1 = newclass "Foo2_1"
+ $P2 = newclass "Foo2_2"
+ $P3 = newclass "Bar2"
+ $I1 = isa $P3, $P1
+ if $I1, fail
+ $I1 = isa $P3, $P2
+ if $I1, fail
+ addparent $P3, $P1
+ $I1 = isa $P3, $P1
+ unless $I1, fail
+ $I1 = isa $P3, $P2
+ if $I1, fail
+ addparent $P3, $P2
+ $I1 = isa $P3, $P2
+ unless $I1, fail
+ removeparent $P3, $P1
+ $I1 = isa $P3, $P1
+ if $I1, fail
+ $I1 = isa $P3, $P2
+ unless $I1, fail
+ removeparent $P3, $P2
+ $I1 = isa $P3, $P1
+ if $I1, fail
+ $I1 = isa $P3, $P2
+ if $I1, fail
+ $I1 = 1
+ ok( $I1, 'multiple')
+fail:
+.end
+
+.sub remove_Y
+ $P1 = newclass "FooY_1"
+ $P2 = newclass "FooY_2"
+ $P3 = newclass "BarY_1"
+ $P4 = newclass "BarY_2"
+ addparent $P3, $P1
+ addparent $P3, $P2
+ $I1 = isa $P4, $P1
+ if $I1, fail
+ $I1 = isa $P4, $P2
+ if $I1, fail
+ addparent $P4, $P3
+ $I1 = isa $P4, $P1
+ unless $I1, fail
+ $I1 = isa $P4, $P2
+ unless $I1, fail
+ removeparent $P4, $P3
+ $I1 = isa $P4, $P1
+ if $I1, fail
+ $I1 = isa $P4, $P2
+ if $I1, fail
+ $I1 = 1
+ ok( $I1, 'Y')
+fail:
+.end
+
+.sub remove_diamond
+ $P1 = newclass "FooD1"
+ $P2 = newclass "FooD2"
+ $P3 = newclass "FooD3"
+ $P4 = newclass "BarD1"
+ addparent $P2, $P1
+ addparent $P3, $P1
+ addparent $P4, $P2
+ addparent $P4, $P3
+ $I1 = isa $P4, $P1
+ unless $I1, fail
+ removeparent $P4, $P2
+ $I1 = isa $P4, $P1
+ unless $I1, fail
+ removeparent $P4, $P3
+ $I1 = isa $P4, $P1
+ if $I1, fail
+ $I1 = 1
+ ok( $I1, 'diamond')
+fail:
+.end
