cvsuser 03/12/05 04:08:14
Modified: classes orderedhash.pmc parrotclass.pmc parrotobject.pmc
include/parrot objects.h
ops object.ops ops.num
src objects.c
t/pmc objects.t
Log:
objects-3
* add some missing methods to OrderedHash
* first try of adding attributes - could be total nonsense
* attribute access methods for classes
* attribute count for objects
* change vtables again, they are distinct now
Revision Changes Path
1.10 +29 -1 parrot/classes/orderedhash.pmc
Index: orderedhash.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/orderedhash.pmc,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -w -r1.9 -r1.10
--- orderedhash.pmc 5 Oct 2003 13:49:26 -0000 1.9
+++ orderedhash.pmc 5 Dec 2003 12:07:38 -0000 1.10
@@ -1,7 +1,7 @@
/* orderedhash.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: orderedhash.pmc,v 1.9 2003/10/05 13:49:26 leo Exp $
+ * $Id: orderedhash.pmc,v 1.10 2003/12/05 12:07:38 leo Exp $
* Overview:
* These are the vtable functions for the OrderedHash base class
* Data Structure and Algorithms:
@@ -53,6 +53,15 @@
return DYNSELF.get_pmc_keyed_int(n);
}
}
+ PMC* get_pmc_keyed_str (STRING* key) {
+ INTVAL n = PerlHash.SELF.get_integer_keyed_str(key);
+ return DYNSELF.get_pmc_keyed_int(n);
+ }
+
+ INTVAL get_integer_keyed_str (STRING* key) {
+ INTVAL n = PerlHash.SELF.get_integer_keyed_str(key);
+ return DYNSELF.get_integer_keyed_int(n);
+ }
void set_pmc_keyed (PMC* key, PMC* value) {
INTVAL n = DYNSELF.elements();
@@ -60,6 +69,18 @@
PerlHash.SELF.set_integer_keyed(key, n);
}
+ void set_pmc_keyed_str (STRING* key, PMC* value) {
+ INTVAL n = DYNSELF.elements();
+ DYNSELF.set_pmc_keyed_int(n, value);
+ PerlHash.SELF.set_integer_keyed_str(key, n);
+ }
+
+ void set_integer_keyed_str (STRING* key, INTVAL value) {
+ INTVAL n = DYNSELF.elements();
+ DYNSELF.set_integer_keyed_int(n, value);
+ PerlHash.SELF.set_integer_keyed_str(key, n);
+ }
+
INTVAL exists_keyed(PMC* key) {
if (PObj_get_FLAGS(key) & KEY_integer_FLAG) {
return SUPER(key);
@@ -68,6 +89,9 @@
return PerlHash.SUPER(key);
}
}
+ INTVAL exists_keyed_str(STRING* key) {
+ return PerlHash.SUPER(key);
+ }
INTVAL defined_keyed(PMC* key) {
if (PObj_get_FLAGS(key) & KEY_integer_FLAG) {
@@ -77,6 +101,10 @@
INTVAL n = PerlHash.SELF.get_integer_keyed(key);
return DYNSELF.defined_keyed_int(n);
}
+ }
+ INTVAL defined_keyed_str(STRING* key) {
+ INTVAL n = PerlHash.SELF.get_integer_keyed_str(key);
+ return DYNSELF.defined_keyed_int(n);
}
void delete_keyed(PMC* key) {
1.11 +35 -10 parrot/classes/parrotclass.pmc
Index: parrotclass.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/parrotclass.pmc,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -w -r1.10 -r1.11
--- parrotclass.pmc 5 Dec 2003 09:36:10 -0000 1.10
+++ parrotclass.pmc 5 Dec 2003 12:07:38 -0000 1.11
@@ -1,7 +1,7 @@
/* parrotclass.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: parrotclass.pmc,v 1.10 2003/12/05 09:36:10 leo Exp $
+ * $Id: parrotclass.pmc,v 1.11 2003/12/05 12:07:38 leo Exp $
* Overview:
* These are the vtable functions for the ParrotClass base class
* Data Structure and Algorithms:
@@ -41,15 +41,6 @@
INTVAL isa(STRING * classname) {
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);
@@ -62,5 +53,39 @@
PMC* find_method(STRING* name) {
PMC *class = VTABLE_get_pmc_keyed_int(INTERP, (PMC *)PMC_data(SELF), 0);
return Parrot_find_method_with_cache(INTERP, class, name);
+ }
+
+ /*
+ * attribute access meths
+ */
+
+ INTVAL elements() {
+ PMC* class_array = (PMC*) PMC_data(SELF);
+ PMC* attr_hash = VTABLE_get_pmc_keyed_int(interpreter,
+ class_array, PCD_ATTRIBUTES);
+ return VTABLE_elements(interpreter, attr_hash);
+ }
+
+ INTVAL get_integer() {
+ return SELF.elements();
+ }
+
+ INTVAL get_integer_keyed_str (STRING* attr) {
+ PMC* class_array = (PMC*) PMC_data(SELF);
+ PMC* attr_hash = VTABLE_get_pmc_keyed_int(interpreter,
+ class_array, PCD_ATTRIBUTES);
+ STRING *class_name = VTABLE_get_string(interpreter,
+ VTABLE_get_pmc_keyed_int(interpreter,
+ class_array, PCD_CLASS_NAME));
+ STRING *full_attr_name = Parrot_sprintf_c(interpreter, "%S%s%S",
+ class_name, PARROT_NAMESPACE_SEPARATOR, attr);
+ if (VTABLE_exists_keyed_str(interpreter, attr_hash, full_attr_name))
+ return VTABLE_get_integer_keyed_str(interpreter,
+ attr_hash, full_attr_name);
+ return -1;
+ }
+
+ INTVAL get_integer_keyed (PMC* attr) {
+ return SELF.get_integer_keyed_str(key_string(interpreter, attr));
}
}
1.11 +13 -1 parrot/classes/parrotobject.pmc
Index: parrotobject.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/parrotobject.pmc,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -w -r1.10 -r1.11
--- parrotobject.pmc 4 Dec 2003 14:21:46 -0000 1.10
+++ parrotobject.pmc 5 Dec 2003 12:07:38 -0000 1.11
@@ -1,7 +1,7 @@
/* parrotobject.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: parrotobject.pmc,v 1.10 2003/12/04 14:21:46 leo Exp $
+ * $Id: parrotobject.pmc,v 1.11 2003/12/05 12:07:38 leo Exp $
* Overview:
* These are the vtable functions for the ParrotObject base class
* Data Structure and Algorithms:
@@ -47,5 +47,17 @@
void init_pmc_props(PMC* init, PMC* props) {
SELF.init();
+ }
+
+ /*
+ * attrib count
+ */
+ INTVAL elements() {
+ PMC* data_array = (PMC*) PMC_data(SELF);
+ return VTABLE_elements(interpreter, data_array) - SELF->cache.int_val;
+ }
+
+ INTVAL get_integer() {
+ return SELF.elements();
}
}
1.11 +2 -1 parrot/include/parrot/objects.h
Index: objects.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/objects.h,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -w -r1.10 -r1.11
--- objects.h 5 Dec 2003 09:36:13 -0000 1.10
+++ objects.h 5 Dec 2003 12:07:54 -0000 1.11
@@ -1,7 +1,7 @@
/* objects.h
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: objects.h,v 1.10 2003/12/05 09:36:13 leo Exp $
+ * $Id: objects.h,v 1.11 2003/12/05 12:07:54 leo Exp $
* Overview:
* Parrot class and object header stuff
* Data Structure and Algorithms:
@@ -44,6 +44,7 @@
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 *);
+INTVAL Parrot_add_attribute(Parrot_Interp, PMC*, STRING*);
#endif
1.20 +8 -0 parrot/ops/object.ops
Index: object.ops
===================================================================
RCS file: /cvs/public/parrot/ops/object.ops,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -w -r1.19 -r1.20
--- object.ops 5 Dec 2003 09:36:15 -0000 1.19
+++ object.ops 5 Dec 2003 12:07:56 -0000 1.20
@@ -267,6 +267,14 @@
Remove attribute $2 from class $1, specified either by name or offset
+=back
+
+op addattrib(out INT, in PMC, in STR) {
+ if (!PObj_is_class_TEST($2))
+ internal_exception(1, "PMC is not a class");
+ $1 = Parrot_add_attribute(interpreter, $2, $3);
+ goto NEXT();
+}
=item B<adddoes>(in PMC, in STR)
1.13 +2 -0 parrot/ops/ops.num
Index: ops.num
===================================================================
RCS file: /cvs/public/parrot/ops/ops.num,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -w -r1.12 -r1.13
--- ops.num 19 Nov 2003 15:43:32 -0000 1.12
+++ ops.num 5 Dec 2003 12:07:56 -0000 1.13
@@ -1278,3 +1278,5 @@
freeze_s_p 1251
thaw_p_s 1252
thaw_p_sc 1253
+addattrib_i_p_s 1254
+addattrib_i_p_sc 1255
1.24 +69 -6 parrot/src/objects.c
Index: objects.c
===================================================================
RCS file: /cvs/public/parrot/src/objects.c,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -w -r1.23 -r1.24
--- objects.c 5 Dec 2003 09:36:17 -0000 1.23
+++ objects.c 5 Dec 2003 12:08:06 -0000 1.24
@@ -1,7 +1,7 @@
/* objects.c
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: objects.c,v 1.23 2003/12/05 09:36:17 leo Exp $
+ * $Id: objects.c,v 1.24 2003/12/05 12:08:06 leo Exp $
* Overview:
* Handles class and object manipulation
* Data Structure and Algorithms:
@@ -11,6 +11,7 @@
*/
#include "parrot/parrot.h"
+#include <assert.h>
/* This should be public, but for right now it's internal */
static PMC *
@@ -179,11 +180,11 @@
}
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
+ * The child class PMC gets a ParrotClass vtable, which is a
* good base to work from
+ * XXX we are leaking ths vtable
*/
- new_vtable = Parrot_clone_vtable(interpreter,
- Parrot_base_vtables[enum_class_ParrotObject]);
+ new_vtable = Parrot_clone_vtable(interpreter, new_class->vtable);
/* register the class */
VTABLE_set_pmc_keyed_str(interpreter, interpreter->class_hash,
@@ -218,13 +219,26 @@
INTVAL attrib_count;
PMC *class_array;
PMC *class;
+ INTVAL class_enum;
+ PMC *class_name;
class = object->vtable->data;
+ /* * remember PMC type */
+ class_enum = object->vtable->base_type;
+ /* put in the real vtable
+ * XXX we are leaking ths vtable
+ */
+ object->vtable = Parrot_clone_vtable(interpreter,
+ Parrot_base_vtables[enum_class_ParrotObject]);
+ /* and set type of class */
+ object->vtable->base_type = class_enum;
/* Grab the attribute count from the parent */
attrib_count = class->cache.int_val;
class_array = PMC_data(class);
+ class_name = VTABLE_get_pmc_keyed_int(interpreter, class_array,
+ PCD_CLASS_NAME);
/* Build the array that hangs off the new object */
new_object_array = pmc_new(interpreter, enum_class_Array);
@@ -234,15 +248,17 @@
/* 0 - class PMC, 1 - class name */
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));
+ class_name);
/* Note the number of used slots */
object->cache.int_val = POD_FIRST_ATTRIB;
PMC_data(object) = new_object_array;
PObj_flag_SET(is_PMC_ptr, object);
+ /* We are an object now */
+ PObj_is_object_SET(object);
- /* We really ought to call the class init routines here... */
+ /* TODO We really ought to call the class init routines here... */
}
PMC *
@@ -401,6 +417,53 @@
string_to_cstring(interpreter, method_name));
}
return method;
+}
+
+INTVAL
+Parrot_add_attribute(Parrot_Interp interpreter, PMC* class, STRING* attr)
+{
+ PMC *class_array;
+ STRING *class_name, *full_attr_name;
+ INTVAL idx;
+ PMC *offs_hash;
+ PMC *attr_hash;
+
+ class_array = (PMC*) PMC_data(class);
+ class_name = VTABLE_get_string(interpreter,
+ VTABLE_get_pmc_keyed_int(interpreter,
+ class_array, PCD_CLASS_NAME));
+ /*
+ * our attributes start at offset found in hash at PCD_ATTRIB_OFFS
+ */
+ offs_hash = VTABLE_get_pmc_keyed_int(interpreter,
+ class_array, PCD_ATTRIB_OFFS);
+ if (VTABLE_exists_keyed_str(interpreter, offs_hash, class_name))
+ idx = VTABLE_get_integer_keyed_str(interpreter, offs_hash, class_name);
+ else {
+ PMC* parent_array = VTABLE_get_pmc_keyed_int(interpreter,
+ class_array, PCD_ALL_PARENTS);
+ if (VTABLE_elements(interpreter, parent_array)) {
+ PMC *parent = VTABLE_get_pmc_keyed_int(interpreter,
+ parent_array, 0);
+ PMC *parent_attr_hash = VTABLE_get_pmc_keyed_int(interpreter,
+ (PMC*) PMC_data(parent), PCD_ATTRIBUTES);
+ idx = VTABLE_elements(interpreter, parent_attr_hash);
+ }
+ else
+ idx = 0;
+ VTABLE_set_integer_keyed_str(interpreter, offs_hash, class_name, idx);
+ }
+ attr_hash = VTABLE_get_pmc_keyed_int(interpreter,
+ class_array, PCD_ATTRIBUTES);
+ full_attr_name = Parrot_sprintf_c(interpreter, "%S%s%S",
+ class_name, PARROT_NAMESPACE_SEPARATOR, attr),
+ idx = VTABLE_elements(interpreter, attr_hash);
+ assert(class->cache.int_val == idx);
+ VTABLE_set_integer_keyed_str(interpreter, attr_hash,
+ full_attr_name, idx);
+ assert(idx + 1 == VTABLE_elements(interpreter, attr_hash));
+ class->cache.int_val = idx + 1;
+ return idx;
}
/*
1.10 +106 -1 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -w -r1.9 -r1.10
--- objects.t 5 Dec 2003 09:36:19 -0000 1.9
+++ objects.t 5 Dec 2003 12:08:14 -0000 1.10
@@ -1,6 +1,6 @@
#! perl -w
-use Parrot::Test tests => 12;
+use Parrot::Test tests => 16;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -279,3 +279,108 @@
ok 4
ok 5
OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "addattrib");
+ newclass P1, "Foo"
+ addattrib I1, P1, "foo_i"
+ print "ok 1\n"
+ print I1
+ print "\n"
+ addattrib I1, P1, "foo_j"
+ print I1
+ print "\n"
+ end
+CODE
+ok 1
+0
+1
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "addattrib subclass");
+ newclass P1, "Foo"
+ addattrib I1, P1, "foo_i"
+ print "ok 1\n"
+ print I1
+ print "\n"
+ addattrib I1, P1, "foo_j"
+ print I1
+ print "\n"
+
+ subclass P2, P1, "Bar"
+ addattrib I1, P2, "bar_i"
+ print "ok 2\n"
+ print I1
+ print "\n"
+ addattrib I1, P2, "bar_j"
+ print I1
+ print "\n"
+ # attr count
+ set I0, P2
+ print I0
+ print "\n"
+ end
+CODE
+ok 1
+0
+1
+ok 2
+2
+3
+4
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "addattrib subclass - get idx");
+ newclass P1, "Foo"
+ addattrib I1, P1, "foo_i"
+ set I2, P1["Foo\x0foo_i"]
+ eq I1, I2, ok1
+ print "not "
+ok1:
+ print "ok 1\n"
+ addattrib I1, P1, "foo_j"
+ set I2, P1["Foo\x0foo_j"]
+ eq I1, I2, ok2
+ print "not "
+ok2:
+ print "ok 2\n"
+
+ subclass P2, P1, "Bar"
+ addattrib I1, P2, "bar_i"
+ set I2, P2["Bar\x0bar_i"]
+ eq I1, I2, ok3
+ print "not "
+ok3:
+ print "ok 3\n"
+ addattrib I1, P2, "bar_j"
+ set I2, P2["Bar\x0bar_j"]
+ eq I1, I2, ok4
+ print "not "
+ok4:
+ print "ok 4\n"
+ end
+CODE
+ok 1
+ok 2
+ok 3
+ok 4
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "object attr count");
+ newclass P1, "Foo"
+ addattrib I1, P1, "foo_i"
+ addattrib I1, P1, "foo_j"
+ set I1, P1
+ print I1
+ print "\n"
+
+ find_type I0, "Foo"
+ new P2, I0
+ set I1, P2
+ print I1
+ print "\n"
+ end
+CODE
+2
+2
+OUTPUT
+
