cvsuser 04/04/09 05:04:49
Modified: include/parrot objects.h
src objects.c
t/pmc object-meths.t
Log:
alternate object initializer calling scheme
Revision Changes Path
1.24 +2 -1 parrot/include/parrot/objects.h
Index: objects.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/objects.h,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -w -r1.23 -r1.24
--- objects.h 3 Apr 2004 15:59:24 -0000 1.23
+++ objects.h 9 Apr 2004 12:04:43 -0000 1.24
@@ -1,7 +1,7 @@
/* objects.h
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: objects.h,v 1.23 2004/04/03 15:59:24 leo Exp $
+ * $Id: objects.h,v 1.24 2004/04/09 12:04:43 leo Exp $
* Overview:
* Parrot class and object header stuff
* Data Structure and Algorithms:
@@ -44,6 +44,7 @@
PMC *Parrot_remove_parent(Parrot_Interp, PMC *, PMC *);
PMC *Parrot_multi_subclass(Parrot_Interp, PMC *, STRING *);
void Parrot_instantiate_object(Parrot_Interp, PMC *);
+void Parrot_instantiate_object_init(Parrot_Interp, PMC *, PMC *);
INTVAL Parrot_object_isa(Parrot_Interp interpreter, PMC *, PMC *);
PMC *Parrot_new_method_cache(Parrot_Interp);
PMC *Parrot_find_method_with_cache(Parrot_Interp, PMC *, STRING *);
1.79 +103 -12 parrot/src/objects.c
Index: objects.c
===================================================================
RCS file: /cvs/public/parrot/src/objects.c,v
retrieving revision 1.78
retrieving revision 1.79
diff -u -w -r1.78 -r1.79
--- objects.c 5 Apr 2004 09:24:04 -0000 1.78
+++ objects.c 9 Apr 2004 12:04:46 -0000 1.79
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: objects.c,v 1.78 2004/04/05 09:24:04 leo Exp $
+$Id: objects.c,v 1.79 2004/04/09 12:04:46 leo Exp $
=head1 NAME
@@ -440,6 +440,7 @@
/* Reset the init method to our instantiation method */
new_vtable->init = Parrot_instantiate_object;
+ new_vtable->init_pmc = Parrot_instantiate_object_init;
new_class->vtable = new_vtable;
/* Put our new vtable in the global table */
@@ -458,16 +459,47 @@
return new_type;
}
+static PMC*
+get_init_meth(Parrot_Interp interpreter, PMC *class,
+ const char * init_name, STRING **meth_str)
+{
+ PMC *prop;
+ STRING *prop_str, *meth;
+#if 0
+ prop_str = const_string(interpreter, init_name);
+ prop = VTABLE_getprop(interpreter, class, prop_str);
+ if (!VTABLE_defined(interpreter, prop))
+ return NULL;
+ meth = VTABLE_get_string(interpreter, prop);
+#else
+ HashBucket *b;
+ PMC *props;
+ if ( !(props = PMC_metadata(class)))
+ return NULL;
+ prop_str = const_string(interpreter, init_name);
+ b = hash_get_bucket(interpreter,
+ (Hash*) PMC_struct_val(props), prop_str);
+ if (!b)
+ return NULL;
+ meth = PMC_str_val((PMC*) b->value);
+#endif
+ *meth_str = meth;
+ return Parrot_find_method_with_cache(interpreter, class, meth);
+}
static void
-do_initcall(Parrot_Interp interpreter, PMC* class, PMC *object)
+do_initcall(Parrot_Interp interpreter, PMC* class, PMC *object, PMC *init)
{
-
SLOTTYPE *class_data = PMC_data(class);
PMC *classsearch_array = get_attrib_num(class_data, PCD_ALL_PARENTS);
PMC *parent_class;
INTVAL i, nparents;
+ int free_it;
+ /*
+ * XXX compat mode
+ */
+ if (!Parrot_getenv("CALL__BUILD", &free_it)) {
nparents = VTABLE_elements(interpreter, classsearch_array);
for (i = nparents - 1; i >= 0; --i) {
parent_class = VTABLE_get_pmc_keyed_int(interpreter,
@@ -477,11 +509,55 @@
}
Parrot_base_vtables[enum_class_delegate]->init(interpreter, object);
}
+ else {
+ /*
+ * 1) if class has a CONSTRUCT property run it on the object
+ * no redispatch
+ */
+ STRING *meth_str;
+ PMC *meth = get_init_meth(interpreter, class, "CONSTRUCT", &meth_str);
+ if (meth) {
+ if (init)
+ Parrot_run_meth_fromc_args_save(interpreter, meth,
+ object, meth_str, "vP", init);
+ else
+ Parrot_run_meth_fromc_save(interpreter, meth,
+ object, meth_str);
+ }
+ /*
+ * 2. if class has a BUILD property call it for all classes
+ * in reverse search order - this class last.
+ */
+ nparents = VTABLE_elements(interpreter, classsearch_array);
+ for (i = nparents - 1; i >= 0; --i) {
+ parent_class = VTABLE_get_pmc_keyed_int(interpreter,
+ classsearch_array, i);
+ meth = get_init_meth(interpreter, parent_class, "BUILD", &meth_str);
+ if (meth) {
+ if (init)
+ Parrot_run_meth_fromc_args_save(interpreter, meth,
+ object, meth_str, "vP", init);
+ else
+ Parrot_run_meth_fromc_save(interpreter, meth,
+ object, meth_str);
+ }
+ }
+ meth = get_init_meth(interpreter, class, "BUILD", &meth_str);
+ if (meth) {
+ if (init)
+ Parrot_run_meth_fromc_args_save(interpreter, meth,
+ object, meth_str, "vP", init);
+ else
+ Parrot_run_meth_fromc_save(interpreter, meth,
+ object, meth_str);
+ }
+ }
+}
/*
=item C<void
-Parrot_instantiate_object(Parrot_Interp interpreter, PMC *object)>
+Parrot_instantiate_object(Parrot_Interp interpreter, PMC *object, PMC *init)>
Creates a Parrot object. Takes a passed-in class PMC that has sufficient
information to describe the layout of the object and, well, makes the
@@ -491,9 +567,24 @@
*/
+static void instantiate_object(Parrot_Interp, PMC *object, PMC *init);
+
+void
+Parrot_instantiate_object_init(Parrot_Interp interpreter,
+ PMC *object, PMC *init)
+{
+ instantiate_object(interpreter, object, init);
+}
+
void
Parrot_instantiate_object(Parrot_Interp interpreter, PMC *object)
{
+ instantiate_object(interpreter, object, NULL);
+}
+
+static void
+instantiate_object(Parrot_Interp interpreter, PMC *object, PMC *init)
+{
SLOTTYPE *new_object_array;
INTVAL attrib_count;
SLOTTYPE *class_array;
@@ -536,7 +627,7 @@
/* We really ought to call the class init routines here...
* this assumes that an object isa delegate
*/
- do_initcall(interpreter, class, object);
+ do_initcall(interpreter, class, object, init);
}
/*
1.16 +84 -2 parrot/t/pmc/object-meths.t
Index: object-meths.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/object-meths.t,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -w -r1.15 -r1.16
--- object-meths.t 4 Apr 2004 08:30:44 -0000 1.15
+++ object-meths.t 9 Apr 2004 12:04:49 -0000 1.16
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: object-meths.t,v 1.15 2004/04/04 08:30:44 leo Exp $
+# $Id: object-meths.t,v 1.16 2004/04/09 12:04:49 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 17;
+use Parrot::Test tests => 19;
use Test::More;
output_like(<<'CODE', <<'OUTPUT', "callmethod - unknown method");
@@ -604,3 +604,85 @@
OUTPUT
};
+$ENV{"CALL__BUILD"} = "1";
+
+output_is(<<'CODE', <<'OUTPUT', "constructor - parents BUILD");
+ new P10, .PerlString
+ set P10, "_new"
+ newclass P1, "Foo"
+ setprop P1, "BUILD", P10
+ subclass P2, P1, "Bar"
+ setprop P2, "BUILD", P10
+ subclass P3, P2, "Baz"
+ setprop P3, "BUILD", P10
+ find_type I1, "Baz"
+ new P3, I1
+ find_type I1, "Bar"
+ new P3, I1
+ find_global P0, "_sub"
+ invokecc
+ print "done\n"
+ end
+
+ .namespace ["Foo"]
+.pcc_sub _new:
+ print "foo_init\n"
+ classname S0, P2
+ print S0
+ print "\n"
+ invoke P1
+
+ .namespace ["Bar"]
+.pcc_sub _new:
+ print "bar_init\n"
+ invoke P1
+
+ .namespace ["Baz"]
+.pcc_sub _new:
+ print "baz_init\n"
+ invoke P1
+
+ .namespace [""] # main again
+.pcc_sub _sub:
+ print "in sub\n"
+ invoke P1
+
+CODE
+foo_init
+Baz
+bar_init
+baz_init
+foo_init
+Bar
+bar_init
+in sub
+done
+OUTPUT
+
+delete $ENV{"CALL__BUILD"};
+
+output_is(<<'CODE', <<'OUTPUT', "same method name in two namespaces");
+##PIR##
+.namespace ["A"]
+.sub foo method
+ .param int i
+
+ .pcc_begin_return
+ .pcc_end_return
+.end
+
+.namespace ["B"]
+.sub foo method
+ .param int i
+
+ .pcc_begin_return
+ .pcc_end_return
+.end
+
+.namespace [""]
+.sub _main @MAIN
+ print "ok\n"
+.end
+CODE
+ok
+OUTPUT
