cvsuser 03/12/05 01:36:19
Modified: classes parrotclass.pmc
include/parrot objects.h
ops object.ops
src objects.c
t/pmc objects.t
Log:
objects-2
* get rid of class and object magic numbers
* change init sequence a bit - creation is with pmc_new so that
thaw could work finally
* implement more bits of isa() and search parents
* test isa
Revision Changes Path
1.10 +23 -18 parrot/classes/parrotclass.pmc
Index: parrotclass.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/parrotclass.pmc,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -w -r1.9 -r1.10
--- parrotclass.pmc 3 Dec 2003 11:17:37 -0000 1.9
+++ parrotclass.pmc 5 Dec 2003 09:36:10 -0000 1.10
@@ -1,7 +1,7 @@
/* parrotclass.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: parrotclass.pmc,v 1.9 2003/12/03 11:17:37 leo Exp $
+ * $Id: parrotclass.pmc,v 1.10 2003/12/05 09:36:10 leo Exp $
* Overview:
* These are the vtable functions for the ParrotClass base class
* Data Structure and Algorithms:
@@ -30,22 +30,29 @@
pmclass ParrotClass need_ext {
void init () {
- /* Hang an array off the data pointer, empty of course */
- PMC_data(SELF) = pmc_new(interpreter, enum_class_SArray);
- /* We will have five entries in this array */
- VTABLE_set_integer_native(interpreter, (PMC*)PMC_data(SELF), (INTVAL)5);
/* No attributes to start with */
SELF->cache.int_val = 0;
/* But we are a class, really */
PObj_is_class_SET(SELF);
/* And, coincidentally, data points to a PMC. Fancy that... */
PObj_flag_SET(is_PMC_ptr, SELF);
+ /* s. Parrot_new_class() for more initialization */
}
INTVAL isa(STRING * classname) {
- PMC *class = Parrot_class_lookup(interpreter, classname);
- if (PMC_IS_NULL(class))
+ PMC *class;
+ /*
+ * a bit tricky:
+ * a ParrotClass has a Parrot_Object vtable but isn't an objecz
+ */
+ if (PObj_is_class_TEST(SELF) &&
+ 0 == string_equal(interpreter, classname,
+ string_from_cstring(interpreter, "ParrotObject", 0))) {
return 0;
+ }
+ if (SUPER(classname))
+ return 1;
+ class = Parrot_class_lookup(interpreter, classname);
return Parrot_object_isa(INTERP, SELF, class);
}
@@ -56,6 +63,4 @@
PMC *class = VTABLE_get_pmc_keyed_int(INTERP, (PMC *)PMC_data(SELF), 0);
return Parrot_find_method_with_cache(INTERP, class, name);
}
-
-
}
1.10 +17 -2 parrot/include/parrot/objects.h
Index: objects.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/objects.h,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -w -r1.9 -r1.10
--- objects.h 3 Dec 2003 11:17:41 -0000 1.9
+++ objects.h 5 Dec 2003 09:36:13 -0000 1.10
@@ -1,7 +1,7 @@
/* objects.h
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: objects.h,v 1.9 2003/12/03 11:17:41 leo Exp $
+ * $Id: objects.h,v 1.10 2003/12/05 09:36:13 leo Exp $
* Overview:
* Parrot class and object header stuff
* Data Structure and Algorithms:
@@ -18,8 +18,23 @@
#define PARROT_NAMESPACE_SEPARATOR "\0"
#define PARROT_NAMESPACE_SEPARATOR_LENGTH 1
+typedef enum {
+ PCD_PARENTS, /* An array of immediate parents */
+ PCD_CLASS_NAME, /* Perlstring */
+ PCD_ALL_PARENTS, /* array in search order */
+ PCD_ATTRIB_OFFS, /* class => offset hash */
+ PCD_ATTRIBUTES, /* class::attrib => offset hash */
+ PCD_MAX
+} PARROT_CLASS_DATA_ENUM;
+
+typedef enum {
+ POD_CLASS, /* class PMC of object */
+ POD_CLASS_NAME, /* Perlstring */
+ POD_FIRST_ATTRIB /* attributes start here */
+} PARROT_OBJECT_DATA_ENUM;
+
PMC *Parrot_single_subclass(Parrot_Interp, PMC *, STRING *);
-PMC *Parrot_new_class(Parrot_Interp, STRING *);
+void Parrot_new_class(Parrot_Interp, PMC *, STRING *);
PMC *Parrot_class_lookup(Parrot_Interp, STRING *);
void Parrot_class_register(Parrot_Interp, STRING *, PMC *);
PMC *Parrot_add_parent(Parrot_Interp, PMC *, PMC *);
1.19 +12 -6 parrot/ops/object.ops
Index: object.ops
===================================================================
RCS file: /cvs/public/parrot/ops/object.ops,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -w -r1.18 -r1.19
--- object.ops 3 Dec 2003 13:27:05 -0000 1.18
+++ object.ops 5 Dec 2003 09:36:15 -0000 1.19
@@ -25,6 +25,8 @@
Call a method on an object as per Parrot's calling conventions. We assume
that all the registers are properly set up.
+All calls assume P2 = objects, S0 = method.
+
=cut
=item B<callmethcc>
@@ -49,7 +51,7 @@
/* Pitch a fit */
}
REG_PMC(0) = method_pmc;
- dest = (opcode_t *)REG_PMC(0)->vtable->invoke(interpreter, REG_PMC(0), expr
NEXT());
+ dest = (opcode_t *)VTABLE_invoke(interpreter, REG_PMC(0), expr NEXT());
goto ADDRESS(dest);
}
@@ -114,7 +116,8 @@
=cut
inline op newclass(out PMC, in STR) {
- $1 = Parrot_new_class(interpreter, $2);
+ PMC* class = $1 = pmc_new(interpreter, enum_class_ParrotClass);
+ Parrot_new_class(interpreter, class, $2);
goto NEXT();
}
@@ -211,8 +214,11 @@
=cut
inline op class(out PMC, in PMC) {
+ if (PObj_is_class_TEST($2))
$1 = VTABLE_get_pmc_keyed_int(interpreter,
- (PMC *)PMC_data($2), 0);
+ (PMC *)PMC_data($2), POD_CLASS);
+ else
+ $1 = $2;
goto NEXT();
}
@@ -226,7 +232,7 @@
PMC* classname_pmc;
classname_pmc = VTABLE_get_pmc_keyed_int(interpreter,
- (PMC *)PMC_data($2), 1);
+ (PMC *)PMC_data($2), POD_CLASS_NAME);
if (classname_pmc) {
$1 = VTABLE_get_string(interpreter, classname_pmc);
}
1.23 +89 -56 parrot/src/objects.c
Index: objects.c
===================================================================
RCS file: /cvs/public/parrot/src/objects.c,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -w -r1.22 -r1.23
--- objects.c 4 Dec 2003 13:56:20 -0000 1.22
+++ objects.c 5 Dec 2003 09:36:17 -0000 1.23
@@ -1,7 +1,7 @@
/* objects.c
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: objects.c,v 1.22 2003/12/04 13:56:20 leo Exp $
+ * $Id: objects.c,v 1.23 2003/12/05 09:36:17 leo Exp $
* Overview:
* Handles class and object manipulation
* Data Structure and Algorithms:
@@ -36,23 +36,28 @@
PMC *child_class;
PMC *child_class_array;
PMC *classname_pmc;
- PMC *temp_pmc;
+ PMC *parents, *temp_pmc;
if (!PObj_is_class_TEST(base_class)) {
internal_exception(NO_CLASS, "Can't subclass a non-class!");
}
child_class = pmc_new(interpreter, enum_class_ParrotClass);
- child_class_array = PMC_data(child_class);
+ /* Hang an array off the data pointer */
+ child_class_array = PMC_data(child_class) =
+ pmc_new(interpreter, enum_class_SArray);
+ /* We will have five entries in this array */
+ VTABLE_set_integer_native(interpreter, child_class_array, PCD_MAX);
/* We have the same number of attributes as our parent */
child_class->cache.int_val = base_class->cache.int_val;
/* Our parent class array has a single member in it */
- temp_pmc = pmc_new(interpreter, enum_class_Array);
- VTABLE_set_integer_native(interpreter, temp_pmc, 1);
- VTABLE_set_pmc_keyed_int(interpreter, child_class_array, 0, temp_pmc);
- VTABLE_set_pmc_keyed_int(interpreter, temp_pmc, 0, base_class);
+ parents = pmc_new(interpreter, enum_class_Array);
+ VTABLE_set_integer_native(interpreter, parents, 1);
+ VTABLE_set_pmc_keyed_int(interpreter, parents, 0, base_class);
+ VTABLE_set_pmc_keyed_int(interpreter, child_class_array, PCD_PARENTS,
+ parents);
/* Set the classname, if we have one */
classname_pmc = pmc_new(interpreter, enum_class_PerlString);
@@ -70,34 +75,37 @@
11, NULL, 0, NULL));
}
- VTABLE_set_pmc_keyed_int(interpreter, child_class_array, 1, classname_pmc);
+ VTABLE_set_pmc_keyed_int(interpreter, child_class_array, PCD_CLASS_NAME,
+ classname_pmc);
/* Our penultimate parent list is a clone of our parent's parent
list, with our parent unshifted onto the beginning */
temp_pmc = pmc_new_noinit(interpreter, enum_class_Array);
VTABLE_clone(interpreter,
VTABLE_get_pmc_keyed_int(interpreter,
- (PMC *)PMC_data(base_class), 2),
+ (PMC *)PMC_data(base_class), PCD_ALL_PARENTS),
temp_pmc);
VTABLE_unshift_pmc(interpreter, temp_pmc, base_class);
- VTABLE_set_pmc_keyed_int(interpreter, child_class_array, 2, temp_pmc);
+ VTABLE_set_pmc_keyed_int(interpreter, child_class_array, PCD_ALL_PARENTS,
+ temp_pmc);
/* Our attribute list is our parent's attribute list */
temp_pmc = pmc_new_noinit(interpreter, enum_class_OrderedHash);
VTABLE_clone(interpreter,
VTABLE_get_pmc_keyed_int(interpreter,
- (PMC *)PMC_data(base_class), 3),
+ (PMC *)PMC_data(base_class), PCD_ATTRIB_OFFS),
+ temp_pmc);
+ VTABLE_set_pmc_keyed_int(interpreter, child_class_array, PCD_ATTRIB_OFFS,
temp_pmc);
- VTABLE_set_pmc_keyed_int(interpreter, child_class_array, 3, temp_pmc);
/* And our full keyed attribute list is our parent's */
temp_pmc = pmc_new_noinit(interpreter, enum_class_OrderedHash);
VTABLE_clone(interpreter,
VTABLE_get_pmc_keyed_int(interpreter,
- (PMC *)PMC_data(base_class), 4),
+ (PMC *)PMC_data(base_class), PCD_ATTRIBUTES),
+ temp_pmc);
+ VTABLE_set_pmc_keyed_int(interpreter, child_class_array, PCD_ATTRIBUTES,
temp_pmc);
- VTABLE_set_pmc_keyed_int(interpreter, child_class_array, 4, temp_pmc);
-
Parrot_class_register(interpreter, child_class_name, child_class);
@@ -108,41 +116,33 @@
*
* Create a brand new class, named what we pass in.
*/
-PMC *
-Parrot_new_class(Parrot_Interp interpreter, STRING *class_name)
+void
+Parrot_new_class(Parrot_Interp interpreter, PMC *class, STRING *class_name)
{
- PMC *new_class;
- PMC *new_class_array;
+ PMC *class_array;
PMC *classname_pmc;
- new_class = pmc_new(interpreter, enum_class_ParrotClass);
- new_class_array = PMC_data(new_class);
- /* We have the same number of attributes as our parent */
- new_class->cache.int_val = 0;
+ /* Hang an array off the data pointer, empty of course */
+ class_array = PMC_data(class) = pmc_new(interpreter, enum_class_SArray);
+ /* We will have five entries in this array */
+ VTABLE_set_integer_native(interpreter, class_array, PCD_MAX);
/* Our parent class array has nothing in it */
- VTABLE_set_pmc_keyed_int(interpreter, new_class_array, 0,
+ VTABLE_set_pmc_keyed_int(interpreter, class_array, PCD_PARENTS,
pmc_new(interpreter, enum_class_Array));
- VTABLE_set_pmc_keyed_int(interpreter, new_class_array, 2,
+ VTABLE_set_pmc_keyed_int(interpreter, class_array, PCD_ALL_PARENTS,
pmc_new(interpreter, enum_class_Array));
- VTABLE_set_pmc_keyed_int(interpreter, new_class_array, 3,
+ VTABLE_set_pmc_keyed_int(interpreter, class_array, PCD_ATTRIB_OFFS,
pmc_new(interpreter, enum_class_OrderedHash));
- VTABLE_set_pmc_keyed_int(interpreter, new_class_array, 4,
+ VTABLE_set_pmc_keyed_int(interpreter, class_array, PCD_ATTRIBUTES,
pmc_new(interpreter, enum_class_OrderedHash));
/* Set the classname, if we have one */
classname_pmc = pmc_new(interpreter, enum_class_PerlString);
VTABLE_set_string_native(interpreter, classname_pmc, class_name);
- VTABLE_set_pmc_keyed_int(interpreter, new_class_array, 1, classname_pmc);
+ VTABLE_set_pmc_keyed_int(interpreter, class_array, PCD_CLASS_NAME,
+ classname_pmc);
- /* Add ourselves to the interpreter's class hash */
- if(Parrot_class_lookup(interpreter, class_name) != PMCNULL) {
- internal_exception(1, "Class %s already registered!\n",
- string_to_cstring(interpreter, class_name));
- }
-
- Parrot_class_register(interpreter, class_name, new_class);
-
- return new_class;
+ Parrot_class_register(interpreter, class_name, class);
}
@@ -166,20 +166,29 @@
Parrot_class_register(Parrot_Interp interpreter, STRING *class_name,
PMC *new_class)
{
- /* Build a new vtable for this class and register it in the
- * global registry .
- * The child class PMC has a ParrotObject vtable, which is a
+ INTVAL new_type;
+ VTABLE *new_vtable;
+
+ /*
+ * register the class in the PMCs name hash and in the
+ * class_name hash
+ */
+ if ((new_type = pmc_type(interpreter, class_name)) > enum_type_undef) {
+ internal_exception(1, "Class %s already registered!\n",
+ string_to_cstring(interpreter, class_name));
+ }
+ new_type = pmc_register(interpreter, class_name);
+ /* Build a new vtable for this class
+ * The child class PMC gets a ParrotObject vtable, which is a
* good base to work from
*/
- VTABLE *new_vtable = Parrot_clone_vtable(interpreter,
+ new_vtable = Parrot_clone_vtable(interpreter,
Parrot_base_vtables[enum_class_ParrotObject]);
- INTVAL new_type = pmc_register(interpreter, class_name);
/* register the class */
VTABLE_set_pmc_keyed_str(interpreter, interpreter->class_hash,
class_name, new_class);
-
/* Set the vtable's type to the newly allocated type */
Parrot_vtable_set_type(interpreter, new_vtable, new_type);
@@ -220,14 +229,15 @@
/* Build the array that hangs off the new object */
new_object_array = pmc_new(interpreter, enum_class_Array);
/* Presize it */
- VTABLE_set_integer_native(interpreter, new_object_array, attrib_count + 2);
+ VTABLE_set_integer_native(interpreter, new_object_array,
+ attrib_count + POD_FIRST_ATTRIB);
/* 0 - class PMC, 1 - class name */
- VTABLE_set_pmc_keyed_int(interpreter, new_object_array, 0, class);
- VTABLE_set_pmc_keyed_int(interpreter, new_object_array, 1,
- VTABLE_get_pmc_keyed_int(interpreter, class_array, 1));
+ VTABLE_set_pmc_keyed_int(interpreter, new_object_array, POD_CLASS, class);
+ VTABLE_set_pmc_keyed_int(interpreter, new_object_array, POD_CLASS_NAME,
+ VTABLE_get_pmc_keyed_int(interpreter, class_array, PCD_CLASS_NAME));
/* Note the number of used slots */
- object->cache.int_val = 2;
+ object->cache.int_val = POD_FIRST_ATTRIB;
PMC_data(object) = new_object_array;
PObj_flag_SET(is_PMC_ptr, object);
@@ -256,15 +266,36 @@
/*=for api objects Parrot_object_is
*
* Is the object an instance of class.
- * XXX: This should check parent classes as well, but it currently doesn't.
*/
INTVAL
-Parrot_object_isa(Parrot_Interp interpreter, PMC *obj, PMC *cl) {
+Parrot_object_isa(Parrot_Interp interpreter, PMC *pmc, PMC *cl) {
PMC * t;
- PMC * object_array = PMC_data(obj);
- t = VTABLE_get_pmc_keyed_int(interpreter, object_array, 0);
+ PMC * object_array = PMC_data(pmc);
+ PMC* classsearch_array; /* The array of classes we're searching */
+ INTVAL i, classcount;
+
+ /* if this is a class */
+ if (PObj_is_class_TEST(pmc)) {
+ t = pmc;
+ /* check if this is self */
+ if (pmc == cl)
+ return 1;
+ }
+ else {
+ /* else get the objects class and the data array */
+ t = VTABLE_get_pmc_keyed_int(interpreter, object_array, POD_CLASS);
+ object_array = PMC_data(t);
+ }
if(t == cl)
return 1;
+ /* If not, time to walk through the parent class array. Wheee */
+ classsearch_array =
+ VTABLE_get_pmc_keyed_int(interpreter, object_array, PCD_ALL_PARENTS);
+ classcount = VTABLE_get_integer(interpreter, classsearch_array);
+ for (i = 0; i < classcount; ++i) {
+ if (VTABLE_get_pmc_keyed_int(interpreter, classsearch_array, i) == cl)
+ return 1;
+ }
return 0;
}
@@ -333,7 +364,7 @@
FQ_method = string_concat(interpreter,
VTABLE_get_string(interpreter,
VTABLE_get_pmc_keyed_int(interpreter,
- (PMC *)PMC_data(class), 1)),
+ (PMC *)PMC_data(class), PCD_CLASS_NAME)),
shortcut_name, 0);
method = find_global(interpreter, FQ_method);
@@ -345,7 +376,8 @@
/* If not, time to walk through the parent class array. Wheee */
classsearch_array =
- VTABLE_get_pmc_keyed_int(interpreter, (PMC *)PMC_data(class), 2);
+ VTABLE_get_pmc_keyed_int(interpreter, (PMC *)PMC_data(class),
+ PCD_ALL_PARENTS);
classcount = VTABLE_get_integer(interpreter, classsearch_array);
for (searchoffset = 0; NULL == method && searchoffset < classcount;
@@ -356,7 +388,8 @@
FQ_method = string_concat(interpreter,
VTABLE_get_string(interpreter,
VTABLE_get_pmc_keyed_int(interpreter,
- (PMC *)PMC_data(curclass), 1)), shortcut_name, 0);
+ (PMC *)PMC_data(curclass), PCD_CLASS_NAME)),
+ shortcut_name, 0);
method = find_global(interpreter, FQ_method);
}
1.9 +96 -1 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -w -r1.8 -r1.9
--- objects.t 3 Dec 2003 11:17:50 -0000 1.8
+++ objects.t 5 Dec 2003 09:36:19 -0000 1.9
@@ -1,6 +1,6 @@
#! perl -w
-use Parrot::Test tests => 9;
+use Parrot::Test tests => 12;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -183,4 +183,99 @@
ok 1
ok 2
1
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "new object - classname");
+ newclass P1, "Foo"
+ find_type I0, "Foo"
+ new P2, I0
+ classname S0, P1 # class
+ print S0
+ print "\n"
+ classname S0, P2 # object
+ print S0
+ print "\n"
+ end
+CODE
+Foo
+Foo
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "isa subclass");
+ newclass P1, "Foo"
+ subclass P2, P1, "Bar"
+ isa I0, P1, "Foo"
+ if I0, ok1
+ print "not "
+ok1:
+ print "ok 1\n"
+ isa I0, P2, "Bar"
+ if I0, ok2
+ print "not "
+ok2:
+ print "ok 2\n"
+ isa I0, P2, "Foo"
+ if I0, ok3
+ print "not "
+ok3:
+ print "ok 3\n"
+ isa I0, P2, "ParrotClass"
+ if I0, ok4
+ print "not "
+ok4:
+ print "ok 4\n"
+ isa I0, P2, "ParrotObject"
+ unless I0, ok5
+ print "not "
+ok5:
+ print "ok 5\n"
+ end
+CODE
+ok 1
+ok 2
+ok 3
+ok 4
+ok 5
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "isa subclass - objects");
+ newclass P3, "Foo"
+ subclass P4, P3, "Bar"
+ find_type I0, "Foo"
+ new P1, I0
+ find_type I0, "Bar"
+ new P2, I0
+
+ isa I0, P1, "Foo"
+ if I0, ok1
+ print "not "
+ok1:
+ print "ok 1\n"
+ isa I0, P2, "Bar"
+ if I0, ok2
+ print "not "
+ok2:
+ print "ok 2\n"
+ isa I0, P2, "Foo"
+ if I0, ok3
+ print "not "
+ok3:
+ print "ok 3\n"
+ isa I0, P2, "ParrotObject"
+ if I0, ok4
+ print "not "
+ok4:
+ print "ok 4\n"
+ isa I0, P2, "ParrotClass"
+ if I0, ok5
+ print "not "
+ok5:
+ print "ok 5\n"
+ end
+CODE
+ok 1
+ok 2
+ok 3
+ok 4
+ok 5
OUTPUT
