cvsuser 04/06/23 05:41:55
Modified: include/parrot pobj.h
lib/Parrot Vtable.pm
src objects.c
t/pmc objects.t
Log:
Pie-thon 4 - override a PMC method in subclass
* new deleg_pmc delegates functions to it's 1st attribute
* for class that subclass a PMC, create a special
vtable that either dispatches as object or as a
deleg_pmc class depending on the existance of the
method
Revision Changes Path
1.44 +9 -9 parrot/include/parrot/pobj.h
Index: pobj.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/pobj.h,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -w -r1.43 -r1.44
--- pobj.h 9 May 2004 14:58:28 -0000 1.43
+++ pobj.h 23 Jun 2004 12:41:40 -0000 1.44
@@ -1,7 +1,7 @@
/* pobj.h
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: pobj.h,v 1.43 2004/05/09 14:58:28 leo Exp $
+ * $Id: pobj.h,v 1.44 2004/06/23 12:41:40 leo Exp $
* Overview:
* Parrot Object data members and flags enum
* Data Structure and Algorithms:
1.40 +31 -1 parrot/lib/Parrot/Vtable.pm
Index: Vtable.pm
===================================================================
RCS file: /cvs/public/parrot/lib/Parrot/Vtable.pm,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -w -r1.39 -r1.40
--- Vtable.pm 15 May 2004 22:12:04 -0000 1.39
+++ Vtable.pm 23 Jun 2004 12:41:48 -0000 1.40
@@ -1,5 +1,5 @@
# Copyright: 2001-2004 The Perl Foundation. All Rights Reserved.
-# $Id: Vtable.pm,v 1.39 2004/05/15 22:12:04 dan Exp $
+# $Id: Vtable.pm,v 1.40 2004/06/23 12:41:48 leo Exp $
=head1 NAME
@@ -204,6 +204,36 @@
/* &end_gen */
EOM
+
+ # finally the name mapping
+ $macros .= <<"EOM";
+/*
+ * vtable slot names
+ */
+#ifdef PARROT_IN_OBJECTS_C
+static const char * const Parrot_vtable_slot_names[] = {
+ "", /* Pointer to package this vtable belongs to */
+ "", /* 'type' value for MMD */
+ "", /* Name of class this vtable is for */
+ "", /* Flags. Duh */
+ "", /* space separated list of interfaces */
+ "", /* space separated list of classes */
+ "", /* To hang data off this vtable */
+
+ /* Vtable Functions */
+EOM
+ for my $entry (@{$vtable}) {
+ $macros .= <<"EOM";
+ \"__$entry->[1]\",
+EOM
+ }
+ $macros .= <<"EOM";
+ NULL
+};
+#endif
+
+EOM
+
$macros;
}
1.97 +84 -18 parrot/src/objects.c
Index: objects.c
===================================================================
RCS file: /cvs/public/parrot/src/objects.c,v
retrieving revision 1.96
retrieving revision 1.97
diff -u -w -r1.96 -r1.97
--- objects.c 23 Jun 2004 08:52:15 -0000 1.96
+++ objects.c 23 Jun 2004 12:41:51 -0000 1.97
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: objects.c,v 1.96 2004/06/23 08:52:15 leo Exp $
+$Id: objects.c,v 1.97 2004/06/23 12:41:51 leo Exp $
=head1 NAME
@@ -18,6 +18,7 @@
*/
+#define PARROT_IN_OBJECTS_C
#include "parrot/parrot.h"
#include <assert.h>
@@ -91,7 +92,6 @@
if (parent_attr_count) {
STRING *parent_name;
INTVAL parent_offset;
- STRING *FQ_name;
STRING *partial_name;
parent_name = VTABLE_get_string(interpreter,
@@ -163,6 +163,64 @@
/*
+=item C<static void create_deleg_pmc_vtable(Interp *, PMC *class, STRING *name)>
+
+Create a vtable that dispatches either to the contained PMC in the first
+attribute (deleg_pmc) or to an overridden method (delegate), depending
+on the existance of the method for this class.
+
+*/
+
+static void
+create_deleg_pmc_vtable(Interp *interpreter, PMC *class, STRING *class_name)
+{
+ PMC *vtable_pmc;
+ VTABLE *vtable, *deleg_pmc_vtable, *delegate_vtable, *object_vtable;
+ int i;
+ const char *meth;
+ STRING meth_str;
+
+ vtable_pmc = get_attrib_num((SLOTTYPE *)PMC_data(class), PCD_OBJECT_VTABLE);
+ vtable = PMC_struct_val(vtable_pmc);
+ deleg_pmc_vtable = Parrot_base_vtables[enum_class_deleg_pmc];
+ object_vtable = Parrot_base_vtables[enum_class_ParrotObject];
+ delegate_vtable = Parrot_base_vtables[enum_class_delegate];
+
+ memset(&meth_str, 0, sizeof(meth_str));
+ meth_str.representation = enum_stringrep_one;
+ for (i = 0; (meth = Parrot_vtable_slot_names[i]); ++i) {
+ if (!*meth)
+ continue;
+ meth_str.strstart = meth;
+ meth_str.strlen = strlen(meth);
+ meth_str.hashval = 0;
+ if (Parrot_find_global(interpreter, class_name, &meth_str)) {
+ /*
+ * if the method exists, keep the ParrotObject aka delegate vtable
+ * slot
+ */
+ LVALUE_CAST(void **,vtable)[i] = ((void**)object_vtable)[i];
+ }
+ else {
+ /*
+ * if the method doesn't exist, put in the deleg_pmc vtable
+ * but only, it ParrotObject hasn't overriden the method
+ */
+ if (((void **)delegate_vtable)[i] == ((void**)object_vtable)[i])
+ LVALUE_CAST(void **,vtable)[i] = ((void**)deleg_pmc_vtable)[i];
+ else
+ LVALUE_CAST(void **,vtable)[i] = ((void**)object_vtable)[i];
+ }
+ }
+ /*
+ * finally if the methods are changed dynamically
+ * this vtable must be changed too
+ * s. src/global.c:Parrot_store_global()
+ */
+}
+
+/*
+
=item C<PMC *
Parrot_single_subclass(Parrot_Interp ointerpreter, PMC *base_class,
STRING *child_class_name)>
@@ -184,8 +242,6 @@
PMC *child_class_array;
PMC *classname_pmc;
PMC *parents, *temp_pmc;
- VTABLE *new_vtable;
- INTVAL new_class_number;
int parent_is_class;
parent_is_class = PObj_is_class_TEST(base_class);
@@ -229,11 +285,10 @@
}
else {
/*
- * we have 1 parent
+ * we have 1 parent, that get's unshifted below
*/
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_set_integer_native(interpreter, temp_pmc, 0);
}
VTABLE_unshift_pmc(interpreter, temp_pmc, base_class);
set_attrib_num(child_class_array, PCD_ALL_PARENTS, temp_pmc);
@@ -247,6 +302,16 @@
rebuild_attrib_stuff(interpreter, child_class);
+ if (!parent_is_class) {
+ /* we append one attribute to hold the PMC */
+ Parrot_add_attribute(interpreter, child_class,
+ CONST_STRING(interpreter, "__value"));
+ /*
+ * then create a vtable derived from ParrotObject and
+ * deleg_pmc - the ParrotObject vtable is already built
+ */
+ create_deleg_pmc_vtable(interpreter, child_class, child_class_name);
+ }
return child_class;
}
@@ -266,9 +331,6 @@
{
PMC *class_array;
PMC *classname_pmc;
- INTVAL new_class_number;
- VTABLE *new_vtable;
- PMC *temp_pmc;
/* Hang an array off the data pointer, empty of course */
class_array = PMC_data(class) = new_attrib_array();
@@ -395,16 +457,13 @@
get_init_meth(Parrot_Interp interpreter, PMC *class,
STRING *prop_str , STRING **meth_str)
{
- PMC *prop;
- union {
- const void * __c_ptr;
- void * __ptr;
- } __ptr_u;
STRING *meth;
HashBucket *b;
PMC *props;
+
*meth_str = NULL;
#if 0
+ PMC *prop;
prop = VTABLE_getprop(interpreter, class, prop_str);
if (!VTABLE_defined(interpreter, prop))
return NULL;
@@ -457,9 +516,17 @@
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))
+ /* if its a PMC, we put one PMC of that type into
+ * the attribute slot #0 and call init() on that PMC
+ */
+ if (!PObj_is_class_TEST(parent_class)) {
+ PMC *attr = pmc_new_noinit(interpreter,
+ parent_class->vtable->base_type);
+ SLOTTYPE *obj_data = PMC_data(object);
+ set_attrib_num(obj_data, POD_FIRST_ATTRIB, attr);
+ VTABLE_init(interpreter, attr);
continue;
+ }
meth = get_init_meth(interpreter, parent_class,
CONST_STRING(interpreter, "BUILD"), &meth_str);
/* no method found and no BUILD property set? */
@@ -1074,7 +1141,6 @@
SLOTTYPE *class_array;
STRING *class_name;
INTVAL idx;
- PMC *offs_hash;
PMC *attr_hash = NULL;
PMC *attr_array;
STRING *full_attr_name;
1.45 +53 -2 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -w -r1.44 -r1.45
--- objects.t 23 Jun 2004 08:52:19 -0000 1.44
+++ objects.t 23 Jun 2004 12:41:55 -0000 1.45
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: objects.t,v 1.44 2004/06/23 08:52:19 leo Exp $
+# $Id: objects.t,v 1.45 2004/06/23 12:41:55 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 40;
+use Parrot::Test tests => 41;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -1165,3 +1165,54 @@
ok 3
OUTPUT
+output_is(<<'CODE', <<'OUTPUT', "PMC as classes - methods");
+##PIR##
+.sub main @MAIN
+ .local pmc MyInt
+ getclass $P0, "Integer"
+ print "ok 1\n"
+ subclass MyInt, $P0, "MyInt"
+ print "ok 2\n"
+ .local pmc i
+ $I0 = find_type "MyInt"
+ i = new $I0
+ 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 = "MyInt("
+ $S0 .= $S1
+ $S0 .= ")"
+ .pcc_begin_return
+ .return $S0
+ .pcc_end_return
+.end
+CODE
+ok 1
+ok 2
+ok 3
+ok 4
+42
+MyInt(42)
+OUTPUT
