cvsuser 04/06/23 01:52:19
Modified: src dod.c objects.c
t/pmc objects.t
Log:
Pie-thon 3 - subclass PMCs
Revision Changes Path
1.116 +6 -4 parrot/src/dod.c
Index: dod.c
===================================================================
RCS file: /cvs/public/parrot/src/dod.c,v
retrieving revision 1.115
retrieving revision 1.116
diff -u -w -r1.115 -r1.116
--- dod.c 23 Jun 2004 07:14:38 -0000 1.115
+++ dod.c 23 Jun 2004 08:52:15 -0000 1.116
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: dod.c,v 1.115 2004/06/23 07:14:38 leo Exp $
+$Id: dod.c,v 1.116 2004/06/23 08:52:15 leo Exp $
=head1 NAME
@@ -260,10 +260,12 @@
* mark vtable->data
*
* XXX these PMCs are constant and shouldn't get collected
- * but t/library/dumper* fails w/o this marking - strange
- * (maybe the VtableCache PMC gets destroyed)
+ * but t/library/dumper* fails w/o this marking.
+ *
+ * It seems that the Class PMC gets DODed - these should
+ * get created as constant PMCs
*/
- for (i = 1; i < (unsigned int)enum_class_max; i++) {
+ for (i = enum_class_core_max; i < (unsigned int)enum_class_max; i++) {
if (Parrot_base_vtables[i]->data)
pobject_lives(interpreter, (PObj*)Parrot_base_vtables[i]->data);
}
1.96 +95 -139 parrot/src/objects.c
Index: objects.c
===================================================================
RCS file: /cvs/public/parrot/src/objects.c,v
retrieving revision 1.95
retrieving revision 1.96
diff -u -w -r1.95 -r1.96
--- objects.c 23 Jun 2004 07:14:38 -0000 1.95
+++ objects.c 23 Jun 2004 08:52:15 -0000 1.96
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: objects.c,v 1.95 2004/06/23 07:14:38 leo Exp $
+$Id: objects.c,v 1.96 2004/06/23 08:52:15 leo Exp $
=head1 NAME
@@ -74,6 +74,12 @@
a_parent_class = VTABLE_get_pmc_keyed_int(interpreter,
parent_array, class_offset);
+ if (!PObj_is_class_TEST(a_parent_class)) {
+ /* this Class inherits from a PMC -
+ * no attributes there
+ */
+ break;
+ }
parent_slots = PMC_data(a_parent_class);
parent_attrib_array = get_attrib_num(parent_slots,
PCD_CLASS_ATTRIBUTES);
@@ -180,15 +186,13 @@
PMC *parents, *temp_pmc;
VTABLE *new_vtable;
INTVAL new_class_number;
+ int parent_is_class;
- if (!PObj_is_class_TEST(base_class)) {
- internal_exception(NO_CLASS, "Can't subclass a non-class!");
- }
+ parent_is_class = PObj_is_class_TEST(base_class);
child_class = pmc_new(interpreter, enum_class_ParrotClass);
/* Hang an array off the data pointer */
- child_class_array = PMC_data(child_class) =
- new_attrib_array();
+ child_class_array = PMC_data(child_class) = new_attrib_array();
set_attrib_flags(child_class);
/* We will have five entries in this array */
set_attrib_array_size(child_class_array, PCD_MAX);
@@ -206,12 +210,6 @@
classname_pmc = pmc_new(interpreter, enum_class_PerlString);
if (child_class_name) {
VTABLE_set_string_native(interpreter, classname_pmc, child_class_name);
-
-#if 0
- /* Add ourselves to the interpreter's class hash */
- VTABLE_set_pmc_keyed_str(interpreter, interpreter->class_hash,
- child_class_name, child_class);
-#endif
}
else {
child_class_name = string_make(interpreter,
@@ -224,30 +222,22 @@
/* Our penultimate parent list is a clone of our parent's parent
list, with our parent unshifted onto the beginning */
- temp_pmc =
- clone_array(interpreter,
+ if (parent_is_class) {
+ temp_pmc = clone_array(interpreter,
get_attrib_num((SLOTTYPE *)PMC_data(base_class),
PCD_ALL_PARENTS));
- VTABLE_unshift_pmc(interpreter, temp_pmc, base_class);
- set_attrib_num(child_class_array, PCD_ALL_PARENTS, temp_pmc);
-
-#if 0
+ }
+ else {
/*
- * recreated in rebuild_attrib_stuff
- * -leo
+ * we have 1 parent
*/
- /* Our attribute list is our parent's attribute list */
- temp_pmc = clone_array(interpreter,
- get_attrib_num((SLOTTYPE *)PMC_data(base_class),
- PCD_ATTRIB_OFFS));
- set_attrib_num(child_class_array, PCD_ATTRIB_OFFS, temp_pmc);
+ temp_pmc = pmc_new(interpreter, enum_class_Array);
+ VTABLE_set_integer_native(interpreter, temp_pmc, 1);
+ VTABLE_set_pmc_keyed_int(interpreter, temp_pmc, 0, base_class);
+ }
+ VTABLE_unshift_pmc(interpreter, temp_pmc, base_class);
+ set_attrib_num(child_class_array, PCD_ALL_PARENTS, temp_pmc);
- /* And our full keyed attribute list is our parent's */
- temp_pmc = clone_array(interpreter,
- get_attrib_num((SLOTTYPE *)PMC_data(base_class),
- PCD_ATTRIBUTES));
- set_attrib_num(child_class_array, PCD_ATTRIBUTES, temp_pmc);
-#endif
/* But we have no attributes of our own. Yet */
temp_pmc = pmc_new(interpreter, enum_class_Array);
@@ -290,15 +280,6 @@
pmc_new(interpreter, enum_class_Array));
set_attrib_num(class_array, PCD_ALL_PARENTS,
pmc_new(interpreter, enum_class_Array));
-#if 0
- /* these two are created in rebuild_attrib_stuf
- * -leo
- */
- set_attrib_num(class_array, PCD_ATTRIB_OFFS,
- pmc_new(interpreter, enum_class_OrderedHash));
- set_attrib_num(class_array, PCD_ATTRIBUTES,
- pmc_new(interpreter, enum_class_OrderedHash));
-#endif
set_attrib_num(class_array, PCD_CLASS_ATTRIBUTES,
pmc_new(interpreter, enum_class_Array));
@@ -368,8 +349,7 @@
PMC *vtable_pmc;
/*
- * register the class in the PMCs name hash and in the
- * class_name hash
+ * register the class in the PMCs name class_hash
*/
if ((new_type = pmc_type(interpreter, class_name)) > enum_type_undef) {
internal_exception(1, "Class %s already registered!\n",
@@ -383,12 +363,6 @@
*/
new_vtable = Parrot_clone_vtable(interpreter, new_class->vtable);
-#if 0
- /* register the class */
- VTABLE_set_pmc_keyed_str(interpreter, interpreter->class_hash,
- class_name, new_class);
-#endif
-
/* Set the vtable's type to the newly allocated type */
Parrot_vtable_set_type(interpreter, new_vtable, new_type);
@@ -411,7 +385,7 @@
Parrot_base_vtables[enum_class_ParrotObject]);
new_vtable->base_type = new_type;
set_attrib_num((SLOTTYPE*)PMC_data(new_class), PCD_OBJECT_VTABLE,
- vtable_pmc = pmc_new(interpreter, enum_class_VtableCache));
+ vtable_pmc = constant_pmc_new(interpreter, enum_class_VtableCache));
PMC_struct_val(vtable_pmc) = new_vtable;
return new_type;
@@ -455,26 +429,6 @@
PMC *classsearch_array = get_attrib_num(class_data, PCD_ALL_PARENTS);
PMC *parent_class;
INTVAL i, nparents;
-#if 0
- int free_it;
- static void *what = (void*)-1;
- /*
- * XXX compat mode
- */
- if (what == (void*)-1)
- what = Parrot_getenv("CALL__BUILD", &free_it);
- if (!what) {
- nparents = VTABLE_elements(interpreter, classsearch_array);
- for (i = nparents - 1; i >= 0; --i) {
- parent_class = VTABLE_get_pmc_keyed_int(interpreter,
- classsearch_array, i);
- Parrot_base_vtables[enum_class_delegate]->init_pmc(interpreter,
- object, parent_class);
- }
- Parrot_base_vtables[enum_class_delegate]->init(interpreter, object);
- }
- else {
-#endif
/*
* 1) if class has a CONSTRUCT property run it on the object
* no redispatch
@@ -503,6 +457,9 @@
for (i = nparents - 1; i >= 0; --i) {
parent_class = VTABLE_get_pmc_keyed_int(interpreter,
classsearch_array, i);
+ /* if its a PMC skip it for now */
+ if (!PObj_is_class_TEST(parent_class))
+ continue;
meth = get_init_meth(interpreter, parent_class,
CONST_STRING(interpreter, "BUILD"), &meth_str);
/* no method found and no BUILD property set? */
@@ -553,9 +510,6 @@
real_exception(interpreter, NULL, METH_NOT_FOUND,
"Class BUILD method ('%Ss') not found", meth_str);
}
-#if 0
- }
-#endif
}
/*
@@ -1067,6 +1021,8 @@
for (searchoffset = 0; searchoffset < classcount; searchoffset++) {
curclass = VTABLE_get_pmc_keyed_int(interpreter,
classsearch_array, searchoffset);
+ if (!PObj_is_class_TEST(curclass))
+ break;
method = Parrot_find_global(interpreter,
VTABLE_get_string(interpreter,
get_attrib_num((SLOTTYPE *)PMC_data(curclass),
1.44 +46 -2 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -w -r1.43 -r1.44
--- objects.t 23 Jun 2004 07:14:42 -0000 1.43
+++ objects.t 23 Jun 2004 08:52:19 -0000 1.44
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: objects.t,v 1.43 2004/06/23 07:14:42 leo Exp $
+# $Id: objects.t,v 1.44 2004/06/23 08:52:19 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 38;
+use Parrot::Test tests => 40;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -1121,3 +1121,47 @@
Integer
OUTPUT
+output_is(<<'CODE', <<'OUTPUT', "PMC as classes - subclass");
+##PIR##
+.sub main @MAIN
+ .local pmc MyInt
+ getclass $P0, "Integer"
+ print "ok 1\n"
+ subclass MyInt, $P0, "MyInt"
+ print "ok 2\n"
+ $S0 = typeof MyInt
+ print $S0
+ print "\n"
+ $I0 = isa MyInt, "MyInt"
+ print $I0
+ $I0 = isa MyInt, "Integer"
+ print $I0
+ print "\n"
+.end
+CODE
+ok 1
+ok 2
+ParrotClass
+11
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "PMC as classes - instantiate");
+##PIR##
+.sub main @MAIN
+ .local pmc MyInt
+ getclass $P0, "Integer"
+ print "ok 1\n"
+ subclass MyInt, $P0, "MyInt"
+ addattribute MyInt, ".i"
+ print "ok 2\n"
+ .local pmc i
+ $I0 = find_type "MyInt"
+ i = new $I0
+ print "ok 3\n"
+.end
+CODE
+ok 1
+ok 2
+ok 3
+OUTPUT
+
