cvsuser 04/07/01 06:45:36
Modified: include/parrot objects.h
src objects.c trace.c
t/pmc objects.t
Log:
subclass classes derived from PMCs
* MyInt2 isa MyInt isa Integer PMC works basically
* Can't overridde methods in MyInt2, which aren't in MyInt
Revision Changes Path
1.26 +2 -2 parrot/include/parrot/objects.h
Index: objects.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/objects.h,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -w -r1.25 -r1.26
--- objects.h 22 Apr 2004 08:55:05 -0000 1.25
+++ objects.h 1 Jul 2004 13:45:28 -0000 1.26
@@ -1,7 +1,7 @@
/* objects.h
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: objects.h,v 1.25 2004/04/22 08:55:05 leo Exp $
+ * $Id: objects.h,v 1.26 2004/07/01 13:45:28 leo Exp $
* Overview:
* Parrot class and object header stuff
* Data Structure and Algorithms:
@@ -39,7 +39,7 @@
PMC *Parrot_single_subclass(Parrot_Interp, PMC *, STRING *);
void Parrot_new_class(Parrot_Interp, PMC *, STRING *);
PMC *Parrot_class_lookup(Parrot_Interp, STRING *);
-INTVAL Parrot_class_register(Parrot_Interp, STRING *, PMC *);
+INTVAL Parrot_class_register(Parrot_Interp, STRING *, PMC *, PMC *);
PMC *Parrot_add_parent(Parrot_Interp, PMC *, PMC *);
PMC *Parrot_remove_parent(Parrot_Interp, PMC *, PMC *);
PMC *Parrot_multi_subclass(Parrot_Interp, PMC *, STRING *);
1.99 +26 -11 parrot/src/objects.c
Index: objects.c
===================================================================
RCS file: /cvs/public/parrot/src/objects.c,v
retrieving revision 1.98
retrieving revision 1.99
diff -u -w -r1.98 -r1.99
--- objects.c 23 Jun 2004 14:06:58 -0000 1.98
+++ objects.c 1 Jul 2004 13:45:33 -0000 1.99
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: objects.c,v 1.98 2004/06/23 14:06:58 leo Exp $
+$Id: objects.c,v 1.99 2004/07/01 13:45:33 leo Exp $
=head1 NAME
@@ -302,7 +302,8 @@
temp_pmc = pmc_new(interpreter, enum_class_Array);
set_attrib_num(child_class_array, PCD_CLASS_ATTRIBUTES, temp_pmc);
- Parrot_class_register(interpreter, child_class_name, child_class);
+ Parrot_class_register(interpreter, child_class_name, child_class,
+ base_class);
rebuild_attrib_stuff(interpreter, child_class);
@@ -355,7 +356,7 @@
VTABLE_set_string_native(interpreter, classname_pmc, class_name);
set_attrib_num(class_array, PCD_CLASS_NAME, classname_pmc);
- Parrot_class_register(interpreter, class_name, class);
+ Parrot_class_register(interpreter, class_name, class, NULL);
rebuild_attrib_stuff(interpreter, class);
}
@@ -408,10 +409,10 @@
INTVAL
Parrot_class_register(Parrot_Interp interpreter, STRING *class_name,
- PMC *new_class)
+ PMC *new_class, PMC *parent)
{
INTVAL new_type;
- VTABLE *new_vtable;
+ VTABLE *new_vtable, *parent_vtable;
PMC *vtable_pmc;
/*
@@ -423,11 +424,17 @@
}
new_type = pmc_register(interpreter, class_name);
/* Build a new vtable for this class
- * The child class PMC gets a ParrotClass vtable, which is a
- * good base to work from
+ * The child class PMC gets the vtable of its parent class or
+ * a ParrotClass vtable
+ *
* XXX we are leaking this vtable
*/
- new_vtable = Parrot_clone_vtable(interpreter, new_class->vtable);
+ parent_vtable = new_class->vtable;
+ if (parent && PObj_is_class_TEST(parent))
+ parent_vtable = parent->vtable;
+ else
+ parent_vtable = new_class->vtable;
+ new_vtable = Parrot_clone_vtable(interpreter, parent_vtable);
/* Set the vtable's type to the newly allocated type */
Parrot_vtable_set_type(interpreter, new_vtable, new_type);
@@ -445,10 +452,18 @@
Parrot_base_vtables[new_type] = new_vtable;
/*
- * prepare object vtable
+ * prepare object vtable - again that of the parent or
+ * a ParrotObject vtable
*/
- new_vtable = Parrot_clone_vtable(interpreter,
- Parrot_base_vtables[enum_class_ParrotObject]);
+ if (parent && PObj_is_class_TEST(parent)) {
+ vtable_pmc =
+ get_attrib_num((SLOTTYPE*)PMC_data(parent), PCD_OBJECT_VTABLE);
+ parent_vtable = PMC_struct_val(vtable_pmc);
+ }
+ else
+ parent_vtable = Parrot_base_vtables[enum_class_ParrotObject];
+
+ new_vtable = Parrot_clone_vtable(interpreter, parent_vtable);
new_vtable->base_type = new_type;
set_attrib_num((SLOTTYPE*)PMC_data(new_class), PCD_OBJECT_VTABLE,
vtable_pmc = constant_pmc_new(interpreter, enum_class_VtableCache));
1.57 +3 -5 parrot/src/trace.c
Index: trace.c
===================================================================
RCS file: /cvs/public/parrot/src/trace.c,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -w -r1.56 -r1.57
--- trace.c 23 Apr 2004 09:21:12 -0000 1.56
+++ trace.c 1 Jul 2004 13:45:33 -0000 1.57
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: trace.c,v 1.56 2004/04/23 09:21:12 jrieks Exp $
+$Id: trace.c,v 1.57 2004/07/01 13:45:33 leo Exp $
=head1 NAME
@@ -70,10 +70,8 @@
PMC_struct_val(pmc));
}
else if (PObj_is_object_TEST(pmc)) {
- /* don't call name, which calls delegate's __name
- * and changes the trace - or fails
- */
- PIO_eprintf(interpreter, "Object=PMC(%#p)", pmc);
+ PIO_eprintf(interpreter, "Object(%Ss)=PMC(%#p)",
+ VTABLE_name(interpreter, pmc), pmc);
}
else {
PIO_eprintf(interpreter, "%S=PMC(%#p)",
1.49 +134 -2 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -w -r1.48 -r1.49
--- objects.t 27 Jun 2004 15:29:58 -0000 1.48
+++ objects.t 1 Jul 2004 13:45:36 -0000 1.49
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: objects.t,v 1.48 2004/06/27 15:29:58 leo Exp $
+# $Id: objects.t,v 1.49 2004/07/01 13:45:36 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 43;
+use Parrot::Test tests => 45;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -1307,3 +1307,135 @@
13
106
OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "PMC as classes - derived 1");
+##PIR##
+.sub main @MAIN
+ .local pmc MyInt
+ .local pmc MyInt2
+ getclass $P0, "Integer"
+ print "ok 1\n"
+ subclass MyInt, $P0, "MyInt"
+ getclass $P1, "MyInt"
+ subclass MyInt2, $P1, "MyInt2"
+ print "ok 2\n"
+ .local pmc i
+ $I0 = find_type "MyInt2"
+ i = new $I0
+ $I0 = isa i, "Integer"
+ print $I0
+ $I0 = isa i, "MyInt"
+ print $I0
+ $I0 = isa i, "MyInt2"
+ print $I0
+ print "\n"
+ print "ok 3\n"
+ i = 42 # set_integer is inherited from Integer
+ print "ok 4\n"
+ $I0 = i # get_integer is overridden below
+ print $I0
+ print "\n"
+ $S0 = i # get_string is overridden below
+ print $S0
+ print "\n"
+.end
+
+.namespace ["MyInt"]
+.sub __get_integer method
+ $I0 = classoffset self, "MyInt"
+ $P0 = getattribute self, $I0
+ $I0 = $P0
+ .pcc_begin_return
+ .return $I0
+ .pcc_end_return
+.end
+.sub __get_string method
+ $I0 = classoffset self, "MyInt"
+ $P0 = getattribute self, $I0
+ $I0 = $P0
+ $S1 = $I0
+ $S0 = typeof self
+ $S0 .= "("
+ $S0 .= $S1
+ $S0 .= ")"
+ .pcc_begin_return
+ .return $S0
+ .pcc_end_return
+.end
+CODE
+ok 1
+ok 2
+111
+ok 3
+ok 4
+42
+MyInt2(42)
+OUTPUT
+
+TODO: {
+ local $TODO = "methods can't be overidden in derived classes";
+
+output_is(<<'CODE', <<'OUTPUT', "PMC as classes - derived 2");
+##PIR##
+.sub main @MAIN
+ .local pmc MyInt
+ .local pmc MyInt2
+ getclass $P0, "Integer"
+ print "ok 1\n"
+ subclass MyInt, $P0, "MyInt"
+ getclass $P1, "MyInt"
+ subclass MyInt2, $P1, "MyInt2"
+ print "ok 2\n"
+ .local pmc i
+ $I0 = find_type "MyInt2"
+ i = new $I0
+ $I0 = isa i, "Integer"
+ print $I0
+ $I0 = isa i, "MyInt"
+ print $I0
+ $I0 = isa i, "MyInt2"
+ print $I0
+ print "\n"
+ print "ok 3\n"
+ i = 42 # set_integer is inherited from Integer
+ print "ok 4\n"
+ $I0 = i # get_integer is overridden below
+ print $I0
+ print "\n"
+ $S0 = i # get_string is overridden below
+ print $S0
+ print "\n"
+.end
+
+.namespace ["MyInt2"]
+.sub __get_integer method
+ $I0 = classoffset self, "MyInt"
+ $P0 = getattribute self, $I0
+ $I0 = $P0
+ .pcc_begin_return
+ .return $I0
+ .pcc_end_return
+.end
+.sub __get_string method
+ $I0 = classoffset self, "MyInt"
+ $P0 = getattribute self, $I0
+ $I0 = $P0
+ $S1 = $I0
+ $S0 = typeof self
+ $S0 .= "("
+ $S0 .= $S1
+ $S0 .= ")"
+ .pcc_begin_return
+ .return $S0
+ .pcc_end_return
+.end
+CODE
+ok 1
+ok 2
+111
+ok 3
+ok 4
+42
+MyInt2(42)
+OUTPUT
+};
