cvsuser 04/06/23 00:14:42
Modified: classes default.pmc delegate.pmc parrotclass.pmc
parrotobject.pmc
ops object.ops
src dod.c global_setup.c inter_create.c objects.c pmc.c
t/pmc objects.t
Log:
Pie-thon 2 - class interface
* better error message for missing methods
* toss the classname_hash - only class_hash is used now
* unify PMC and ParrotClass registering
* prepare PMCs to behave as Classes
* use Parrot_class_lookup() for object.ops
Revision Changes Path
1.90 +14 -1 parrot/classes/default.pmc
Index: default.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/default.pmc,v
retrieving revision 1.89
retrieving revision 1.90
diff -u -w -r1.89 -r1.90
--- default.pmc 22 Jun 2004 13:13:31 -0000 1.89
+++ default.pmc 23 Jun 2004 07:14:30 -0000 1.90
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: default.pmc,v 1.89 2004/06/22 13:13:31 leo Exp $
+$Id: default.pmc,v 1.90 2004/06/23 07:14:30 leo Exp $
=head1 NAME
@@ -754,6 +754,19 @@
/*
+=item C<PMC* get_class()>
+
+Returns SELF. A PMC is it's own class.
+
+=cut
+
+*/
+ PMC* get_class() {
+ return SELF;
+ }
+
+/*
+
=item C<void visit(visit_info *info)>
Used by DOD to mark the PMC.
1.25 +11 -3 parrot/classes/delegate.pmc
Index: delegate.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/delegate.pmc,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -w -r1.24 -r1.25
--- delegate.pmc 6 Apr 2004 16:40:23 -0000 1.24
+++ delegate.pmc 23 Jun 2004 07:14:30 -0000 1.25
@@ -1,6 +1,6 @@
/*
Copyright: 2003 The Perl Foundation. All Rights Reserved.
-$Id: delegate.pmc,v 1.24 2004/04/06 16:40:23 leo Exp $
+$Id: delegate.pmc,v 1.25 2004/06/23 07:14:30 leo Exp $
=head1 NAME
@@ -82,9 +82,17 @@
find_or_die(Parrot_Interp interpreter, PMC *pmc, STRING *meth) {
PMC *returnPMC = find_meth(interpreter, pmc, meth);
if (PMC_IS_NULL(returnPMC)) {
+ PMC *class = pmc;
+ if (PObj_is_object_TEST(pmc)) {
+ class = GET_CLASS((Buffer *)PMC_data(pmc), pmc);
+ }
internal_exception(METH_NOT_FOUND,
- "Can't find method '%s' for object",
- string_to_cstring(interpreter, meth));
+ "Can't find method '%s' for object '%s'",
+ string_to_cstring(interpreter, meth),
+ string_to_cstring(interpreter, PMC_str_val(
+ get_attrib_num((SLOTTYPE *)PMC_data(class),
+ PCD_CLASS_NAME)))
+ );
}
return returnPMC;
}
1.23 +5 -1 parrot/classes/parrotclass.pmc
Index: parrotclass.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/parrotclass.pmc,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -w -r1.22 -r1.23
--- parrotclass.pmc 4 Apr 2004 07:49:29 -0000 1.22
+++ parrotclass.pmc 23 Jun 2004 07:14:30 -0000 1.23
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: parrotclass.pmc,v 1.22 2004/04/04 07:49:29 leo Exp $
+$Id: parrotclass.pmc,v 1.23 2004/06/23 07:14:30 leo Exp $
=head1 NAME
@@ -117,6 +117,10 @@
Returns whether the class can perform C<*method>.
+=item C<PMC *get_class()>
+
+Return SELF.
+
=cut
*/
1.30 +21 -1 parrot/classes/parrotobject.pmc
Index: parrotobject.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/parrotobject.pmc,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -w -r1.29 -r1.30
--- parrotobject.pmc 5 Apr 2004 16:12:50 -0000 1.29
+++ parrotobject.pmc 23 Jun 2004 07:14:30 -0000 1.30
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: parrotobject.pmc,v 1.29 2004/04/05 16:12:50 leo Exp $
+$Id: parrotobject.pmc,v 1.30 2004/06/23 07:14:30 leo Exp $
=head1 NAME
@@ -127,6 +127,26 @@
Finds the method for C<*name>.
+=item C<PMC* get_attr(INTVAL idx)>
+
+Return attribute number C<idx>.
+
+=item C<PMC* get_attr_str(STRING *name)>
+
+Return attribute named C<name>.
+
+=item C<void set_attr(INTVAL idx, PMC *val)>
+
+Set attribute number C<idx>.
+
+=item C<void set_attr_str(STRING *name, PMC *val)>
+
+Set attribute named C<name>.
+
+=item C<PMC *get_class()>
+
+Return the class of this object.
+
=cut
*/
1.44 +10 -10 parrot/ops/object.ops
Index: object.ops
===================================================================
RCS file: /cvs/public/parrot/ops/object.ops,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -w -r1.43 -r1.44
--- object.ops 4 Apr 2004 14:18:18 -0000 1.43
+++ object.ops 23 Jun 2004 07:14:35 -0000 1.44
@@ -208,9 +208,8 @@
}
op subclass(out PMC, in STR, in STR) :object_classes {
- PMC *class = VTABLE_get_pmc_keyed_str(interpreter,
- interpreter->class_hash, $2);
- if (!class || !PObj_is_class_TEST(class)) {
+ PMC *class = Parrot_class_lookup(interpreter, $2);
+ if (PMC_IS_NULL(class)) {
internal_exception(NO_CLASS, "Class '%s' doesn't exist\n",
string_to_cstring( interpreter, $3 ));
}
@@ -219,9 +218,8 @@
}
op subclass(out PMC, in STR) :object_classes {
- PMC *class = VTABLE_get_pmc_keyed_str(interpreter,
- interpreter->class_hash, $2);
- if (!class || !PObj_is_class_TEST(class)) {
+ PMC *class = Parrot_class_lookup(interpreter, $2);
+ if (PMC_IS_NULL(class)) {
internal_exception(NO_CLASS, "Class '%s' doesn't exist\n",
string_to_cstring( interpreter, $2 ));
}
@@ -236,7 +234,8 @@
=cut
inline op findclass(out INT, in STR) :object_base {
- $1 = VTABLE_exists_keyed_str(interpreter, interpreter->class_hash, $2);
+ PMC *class = Parrot_class_lookup(interpreter, $2);
+ $1 = !PMC_IS_NULL(class);
goto NEXT();
}
@@ -251,12 +250,13 @@
=cut
inline op getclass(out PMC, in STR) :object_classes {
- if (VTABLE_exists_keyed_str(interpreter, interpreter->class_hash, $2)) {
- $1 = VTABLE_get_pmc_keyed_str(interpreter, interpreter->class_hash, $2);
- } else {
+ PMC *class = Parrot_class_lookup(interpreter, $2);
+ if (PMC_IS_NULL(class)) {
internal_exception(NO_CLASS, "Class '%s' doesn't exist\n",
string_to_cstring( interpreter, $2 ));
}
+ else
+ $1 = class;
goto NEXT();
}
1.115 +13 -1 parrot/src/dod.c
Index: dod.c
===================================================================
RCS file: /cvs/public/parrot/src/dod.c,v
retrieving revision 1.114
retrieving revision 1.115
diff -u -w -r1.114 -r1.115
--- dod.c 22 Jun 2004 10:57:23 -0000 1.114
+++ dod.c 23 Jun 2004 07:14:38 -0000 1.115
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: dod.c,v 1.114 2004/06/22 10:57:23 leo Exp $
+$Id: dod.c,v 1.115 2004/06/23 07:14:38 leo Exp $
=head1 NAME
@@ -256,6 +256,18 @@
}
}
+ /*
+ * 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)
+ */
+ for (i = 1; i < (unsigned int)enum_class_max; i++) {
+ if (Parrot_base_vtables[i]->data)
+ pobject_lives(interpreter, (PObj*)Parrot_base_vtables[i]->data);
+ }
+
/* Walk through the stashes */
stash = interpreter->globals;
while (stash) {
1.53 +7 -8 parrot/src/global_setup.c
Index: global_setup.c
===================================================================
RCS file: /cvs/public/parrot/src/global_setup.c,v
retrieving revision 1.52
retrieving revision 1.53
diff -u -w -r1.52 -r1.53
--- global_setup.c 18 Apr 2004 15:10:55 -0000 1.52
+++ global_setup.c 23 Jun 2004 07:14:38 -0000 1.53
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: global_setup.c,v 1.52 2004/04/18 15:10:55 leo Exp $
+$Id: global_setup.c,v 1.53 2004/06/23 07:14:38 leo Exp $
=head1 NAME
@@ -59,11 +59,9 @@
#endif
- /* TODO allocate core vtable table only once - or per interpreter
- *
- * this interfers with JITted NCI on i386, where the method stubs
- * are stored inside vtable->method_table - different threads get
- * the same code
+ /*
+ * TODO allocate core vtable table only once - or per interpreter
+ * divide globals into real globals and per interpreter
*/
if (!Parrot_base_vtables)
Parrot_base_vtables =
@@ -76,8 +74,9 @@
/* Now register the names of the PMCs */
- /* We need a hash */
- classname_hash = pmc_new(interpreter, enum_class_PerlHash);
+ /* We need a class hash */
+ interpreter->class_hash = classname_hash =
+ pmc_new(interpreter, enum_class_PerlHash);
/* Now fill the hash */
Parrot_register_core_pmcs(interpreter, classname_hash);
1.4 +1 -4 parrot/src/inter_create.c
Index: inter_create.c
===================================================================
RCS file: /cvs/public/parrot/src/inter_create.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- inter_create.c 22 Jun 2004 14:31:44 -0000 1.3
+++ inter_create.c 23 Jun 2004 07:14:38 -0000 1.4
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: inter_create.c,v 1.3 2004/06/22 14:31:44 leo Exp $
+$Id: inter_create.c,v 1.4 2004/06/23 07:14:38 leo Exp $
=head1 NAME
@@ -234,9 +234,6 @@
PIO_init(interpreter);
/* Done. Return and be done with it */
- /* Add in the class hash. Bit of a hack, probably, as there's
- altogether too much overlap with the PMC classes */
- interpreter->class_hash = pmc_new(interpreter, enum_class_PerlHash);
/* Okay, we've finished doing anything that might trigger GC.
* Actually, we could enable DOD/GC earlier, but here all setup is
1.95 +17 -5 parrot/src/objects.c
Index: objects.c
===================================================================
RCS file: /cvs/public/parrot/src/objects.c,v
retrieving revision 1.94
retrieving revision 1.95
diff -u -w -r1.94 -r1.95
--- objects.c 22 Jun 2004 10:57:23 -0000 1.94
+++ objects.c 23 Jun 2004 07:14:38 -0000 1.95
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: objects.c,v 1.94 2004/06/22 10:57:23 leo Exp $
+$Id: objects.c,v 1.95 2004/06/23 07:14:38 leo Exp $
=head1 NAME
@@ -207,9 +207,11 @@
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,
@@ -326,10 +328,18 @@
PMC *
Parrot_class_lookup(Parrot_Interp interpreter, STRING *class_name)
{
- if (VTABLE_exists_keyed_str(interpreter, interpreter->class_hash,
- class_name))
- return VTABLE_get_pmc_keyed_str(interpreter, interpreter->class_hash,
- class_name);
+ HashBucket *b;
+ b = hash_get_bucket(interpreter,
+ (Hash*) PMC_struct_val(interpreter->class_hash), class_name);
+ if (b) {
+ INTVAL type = PMC_int_val((PMC*)b->value);
+ PMC *pmc = Parrot_base_vtables[type]->data;
+ if (!pmc) {
+ pmc = Parrot_base_vtables[type]->data =
+ pmc_new_noinit(interpreter, type);
+ }
+ return pmc;
+ }
return PMCNULL;
}
@@ -373,9 +383,11 @@
*/
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);
1.82 +26 -12 parrot/src/pmc.c
Index: pmc.c
===================================================================
RCS file: /cvs/public/parrot/src/pmc.c,v
retrieving revision 1.81
retrieving revision 1.82
diff -u -w -r1.81 -r1.82
--- pmc.c 11 Jun 2004 16:29:06 -0000 1.81
+++ pmc.c 23 Jun 2004 07:14:38 -0000 1.82
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: pmc.c,v 1.81 2004/06/11 16:29:06 dan Exp $
+$Id: pmc.c,v 1.82 2004/06/23 07:14:38 leo Exp $
=head1 NAME
@@ -181,6 +181,13 @@
PMC *pmc;
VTABLE *vtable = Parrot_base_vtables[base_type];
+ if (!vtable) {
+ /* This is usually because you either didn't call init_world early
+ * enough or you added a new PMC class without adding
+ * Parrot_(classname)_class_init to init_world. */
+ PANIC("Null vtable used");
+ }
+
if (vtable->flags & VTABLE_IS_CONST_FLAG) {
/* put the normal vtable in, so that the pmc can be initialized first
* parrot or user code has to set the _ro property then,
@@ -206,14 +213,23 @@
}
pmc->vtable = vtable;
-
- if (!vtable || !vtable->init) {
- /* This is usually because you either didn't call init_world early
- * enough or you added a new PMC class without adding
- * Parrot_(classname)_class_init to init_world. */
- PANIC("Null vtable used or missing init");
- return NULL;
+ /*
+ * class interface - a PMC is it's own class
+ * XXX use a separate vtable entry?
+ * A ParrotObject has already the ParrotClass PMC in data
+ */
+ if (!vtable->data) {
+ /* can't put this PMC in: if it needs timely destruction
+ * it'll not get destroyed, so put in another PMC
+ *
+ * we should do that in pmc_register, but this doesn't
+ * work for dynamic PMCs, which don't have a vtable
+ * when they call pmc_register
+ */
+ PMC *class = vtable->data = new_pmc_header(interpreter, PObj_constant_FLAG);
+ class->vtable = vtable;
}
+
#if GC_VERBOSE
if (Interp_flags_TEST(interpreter, PARROT_TRACE_FLAG)) {
/* XXX make a more verbose trace flag */
@@ -396,8 +412,7 @@
return type;
}
- classname_hash = VTABLE_get_pmc_keyed_int(interp, interp->iglobals,
- IGLOBALS_CLASSNAME_HASH);
+ classname_hash = interp->class_hash;
type = enum_class_max++;
/* Have we overflowed the table? */
if (enum_class_max > class_table_size - 1) {
@@ -442,8 +457,7 @@
* probe for PMC types
*/
PARROT_WARNINGS_off(interp, PARROT_WARNINGS_UNDEF_FLAG);
- classname_hash = VTABLE_get_pmc_keyed_int(interp,
- interp->iglobals, IGLOBALS_CLASSNAME_HASH);
+ classname_hash = interp->class_hash;
return_val = VTABLE_get_integer_keyed_str(interp, classname_hash, name);
if (w)
1.43 +18 -2 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -w -r1.42 -r1.43
--- objects.t 18 May 2004 16:47:23 -0000 1.42
+++ objects.t 23 Jun 2004 07:14:42 -0000 1.43
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: objects.t,v 1.42 2004/05/18 16:47:23 dan Exp $
+# $Id: objects.t,v 1.43 2004/06/23 07:14:42 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 37;
+use Parrot::Test tests => 38;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -1105,3 +1105,19 @@
CODE
/Attribute 'Foo(.*?i)?' already exists/
OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "PMC as classes");
+ getclass P0, "Integer"
+ print "ok 1\n"
+ getclass P0, "Integer"
+ print "ok 2\n"
+ typeof S0, P0
+ print S0
+ print "\n"
+ end
+CODE
+ok 1
+ok 2
+Integer
+OUTPUT
+
