cvsuser 04/04/03 12:44:47
Modified: classes parrotclass.pmc parrotobject.pmc
docs/pdds pdd15_objects.pod
ops object.ops
src objects.c
t/pmc objects.t
. vtable.tbl
Log:
attribute vtables
(Shouldn't ask silly questions on p6i but first read pdd15 again)
* implement speced vtables
* change ops to use vtables
* some comments in Parrot_add_attribute
* check against duplicate attribs
* pdd15 updates
Revision Changes Path
1.21 +4 -1 parrot/classes/parrotclass.pmc
Index: parrotclass.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/parrotclass.pmc,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -w -r1.20 -r1.21
--- parrotclass.pmc 5 Mar 2004 07:26:44 -0000 1.20
+++ parrotclass.pmc 3 Apr 2004 20:44:31 -0000 1.21
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: parrotclass.pmc,v 1.20 2004/03/05 07:26:44 leo Exp $
+$Id: parrotclass.pmc,v 1.21 2004/04/03 20:44:31 leo Exp $
=head1 NAME
@@ -121,6 +121,9 @@
return VTABLE_find_method(interpreter, SELF, method) != NULL;
}
+ PMC* get_class() {
+ return SELF;
+ }
}
/*
1.27 +20 -1 parrot/classes/parrotobject.pmc
Index: parrotobject.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/parrotobject.pmc,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -w -r1.26 -r1.27
--- parrotobject.pmc 26 Mar 2004 19:09:34 -0000 1.26
+++ parrotobject.pmc 3 Apr 2004 20:44:31 -0000 1.27
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: parrotobject.pmc,v 1.26 2004/03/26 19:09:34 leo Exp $
+$Id: parrotobject.pmc,v 1.27 2004/04/03 20:44:31 leo Exp $
=head1 NAME
@@ -134,6 +134,25 @@
return Parrot_find_method_with_cache(INTERP, class, name);
}
+ PMC* get_attr(INTVAL idx) {
+ return Parrot_get_attrib_by_num(interpreter, SELF, idx);
+ }
+
+ PMC* get_attr_str(STRING* idx) {
+ return Parrot_get_attrib_by_str(interpreter, SELF, idx);
+ }
+
+ void set_attr(INTVAL idx, PMC* value) {
+ return Parrot_set_attrib_by_num(interpreter, SELF, idx, value);
+ }
+
+ void set_attr_str(STRING* idx, PMC* value) {
+ return Parrot_set_attrib_by_str(interpreter, SELF, idx, value);
+ }
+
+ PMC* get_class() {
+ return GET_CLASS(PMC_data(SELF), SELF);
+ }
}
/*
1.38 +29 -8 parrot/docs/pdds/pdd15_objects.pod
Index: pdd15_objects.pod
===================================================================
RCS file: /cvs/public/parrot/docs/pdds/pdd15_objects.pod,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -w -r1.37 -r1.38
--- pdd15_objects.pod 3 Apr 2004 19:49:44 -0000 1.37
+++ pdd15_objects.pod 3 Apr 2004 20:44:34 -0000 1.38
@@ -1,5 +1,5 @@
# Copyright: 2001-2004 The Perl Foundation. All Rights Reserved.
-# $Id: pdd15_objects.pod,v 1.37 2004/04/03 19:49:44 leo Exp $
+# $Id: pdd15_objects.pod,v 1.38 2004/04/03 20:44:34 leo Exp $
=head1 NAME
@@ -386,15 +386,23 @@
Returns true or false to note whether the object in question
implements the interface passed in.
-=item getattr(int)
+=item get_attr(INTVAL)
Returns the attribute at the passed-in offset for the object.
-=item setattr(int, PMC *)
+=item get_attr(STRING*)
+
+Returns the attribute with the fully qualified name for the object.
+
+=item set_attr(INTVAL, PMC *)
Sets the attribute for the passed-in offset to the passed-in PMC value
-=item getclass
+=item set_attr(STRING*, PMC *)
+
+Set the attribute with the fully qualified name for the object.
+
+=item get_class
Returns the class PMC for the object.
@@ -441,8 +449,8 @@
Adding the attributes C<a> and C<b> to the new class C<Foo>:
newclass $P0, "Foo"
- addattribute $P0, "a", "Foo::a" # This is offset 0
- addattribute $P0, "b", "Foo::b" # This is offset 1
+ addattribute $P0, "a" # This is offset 0 + classoffset
+ addattribute $P0, "b" # This is offset 1 + classoffset
=head2 Instantiating an object
@@ -458,14 +466,14 @@
Calling the method C<Xyzzy> on an object, assuming the PDD03 calling
conventions are respected:
- callmethod "Xyzzy" (Unimplemented)
+ callmethod "Xyzzy"
set S0, "Xyzzy"
callmethod
Or, if a return continuation needs constructing:
- callmethodcc "Xyzzy" (Unimplemented)
+ callmethodcc "Xyzzy"
set S0, "Xyzzy"
callmethodcc
@@ -481,6 +489,10 @@
BOffset = BaseOffset + 1
getattribute $P1, $P0, BOffset
+Or with named access, if it isn't time critical:
+
+ getattribute $P1, $P0, "Foo\x0b"
+
=head1 Explanations
To get a new class, you can do a C<newclass>, which creates a new
@@ -1105,6 +1117,10 @@
=over 4
+=item Version 1.3
+
+April 3, 2004
+
=item Version 1.2
February 9, 2004
@@ -1122,6 +1138,11 @@
=head1 CHANGES
=over 4
+
+=item Version 1.3
+
+Removed some unimplemented notes. Changed vtables to get_*, set_* so that they
+match other vtable function syntax.
=item Version 1.2
1.42 +5 -8 parrot/ops/object.ops
Index: object.ops
===================================================================
RCS file: /cvs/public/parrot/ops/object.ops,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -w -r1.41 -r1.42
--- object.ops 3 Apr 2004 19:49:53 -0000 1.41
+++ object.ops 3 Apr 2004 20:44:37 -0000 1.42
@@ -278,10 +278,7 @@
=cut
inline op class(out PMC, in PMC) :object_classes {
- if (PObj_is_object_TEST($2))
- $1 = GET_CLASS((Buffer *)PMC_data($2), $2);
- else
- $1 = $2;
+ $1 = VTABLE_get_class(interpreter, $2);
goto NEXT();
}
@@ -360,12 +357,12 @@
=cut
inline op getattribute(out PMC, in PMC, in INT) :object_classes {
- $1 = Parrot_get_attrib_by_num(interpreter, $2, $3);
+ $1 = VTABLE_get_attr(interpreter, $2, $3);
goto NEXT();
}
inline op getattribute(out PMC, in PMC, in STR) :object_classes {
- $1 = Parrot_get_attrib_by_str(interpreter, $2, $3);
+ $1 = VTABLE_get_attr_str(interpreter, $2, $3);
goto NEXT();
}
@@ -378,12 +375,12 @@
=cut
inline op setattribute(in PMC, in INT, in PMC) :object_classes {
- Parrot_set_attrib_by_num(interpreter, $1, $2, $3);
+ VTABLE_set_attr(interpreter, $1, $2, $3);
goto NEXT();
}
inline op setattribute(in PMC, in STR, in PMC) :object_classes {
- Parrot_set_attrib_by_str(interpreter, $1, $2, $3);
+ VTABLE_set_attr_str(interpreter, $1, $2, $3);
goto NEXT();
}
1.75 +46 -5 parrot/src/objects.c
Index: objects.c
===================================================================
RCS file: /cvs/public/parrot/src/objects.c,v
retrieving revision 1.74
retrieving revision 1.75
diff -u -w -r1.74 -r1.75
--- objects.c 3 Apr 2004 15:59:29 -0000 1.74
+++ objects.c 3 Apr 2004 20:44:40 -0000 1.75
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: objects.c,v 1.74 2004/04/03 15:59:29 leo Exp $
+$Id: objects.c,v 1.75 2004/04/03 20:44:40 leo Exp $
=head1 NAME
@@ -962,15 +962,20 @@
STRING *full_attr_name;
class_array = (SLOTTYPE *)PMC_data(class);
- class_name = VTABLE_get_string(interpreter, get_attrib_num(class_array,
- PCD_CLASS_NAME));
+ class_name = VTABLE_get_string(interpreter,
+ get_attrib_num(class_array, PCD_CLASS_NAME));
attr_array = get_attrib_num(class_array, PCD_CLASS_ATTRIBUTES);
attr_hash = get_attrib_num(class_array, PCD_ATTRIBUTES);
idx = VTABLE_elements(interpreter, attr_array);
VTABLE_set_integer_native(interpreter, attr_array, idx + 1);
VTABLE_set_string_keyed_int(interpreter, attr_array, idx, attr);
- full_attr_name = string_concat(interpreter, class_name,
string_from_cstring(interpreter, "\0", 1), 0);
+ full_attr_name = string_concat(interpreter, class_name,
+ string_from_cstring(interpreter, "\0", 1), 0);
full_attr_name = string_concat(interpreter, full_attr_name, attr, 0);
+ /* TODO escape NUL char */
+ if (VTABLE_exists_keyed_str(interpreter, attr_hash, full_attr_name))
+ internal_exception(1, "Attribute '%s' already exists",
+ string_to_cstring(interpreter, full_attr_name));
/*
* TODO check if someone is trying to add attributes to a parent class
@@ -978,6 +983,19 @@
*/
idx = VTABLE_elements(interpreter, attr_hash);
assert(PMC_int_val(class) == idx);
+ /*
+ * attr_hash is an OrderedHash so the line below could be:
+ *
+ * VTABLE_set_string_keyed_str(interpreter, attr_hash,
+ * full_attr_name, attr);
+ *
+ * so that we have a mapping full_attr_name => attr_name
+ * the index is in the OrderedHash anyway
+ *
+ * if this isn't needed a plain hash is faster
+ *
+ * -leo
+ */
VTABLE_set_integer_keyed_str(interpreter, attr_hash,
full_attr_name, idx);
assert(idx + 1 == VTABLE_elements(interpreter, attr_hash));
@@ -993,6 +1011,11 @@
Returns attribute number C<attrib> from C<object>. Presumably the code
is asking for the correct attribute number.
+=item C<PMC *
+Parrot_get_attrib_by_str(Parrot_Interp interpreter, PMC *object, STRING *attr)>
+
+Returns attribute with full qualified name C<attr> from C<object>.
+
*/
PMC *
@@ -1009,7 +1032,8 @@
return get_attrib_num(attrib_array, attrib);
}
else {
- internal_exception(INTERNAL_NOT_IMPLEMENTED, "Can't get non-core object
attribs yet");
+ internal_exception(INTERNAL_NOT_IMPLEMENTED,
+ "Can't get non-core object attribs yet");
}
return NULL;
}
@@ -1046,6 +1070,23 @@
POD_FIRST_ATTRIB +
attr_str_2_num(interpreter, object, attr));
}
+
+/*
+
+=item C<PMC *
+Parrot_set_attrib_by_num(Parrot_Interp interpreter, PMC *object,
+ INTVAL attrib, PMC *value)>
+
+Set attribute number C<attrib> from C<object> to C<value>. Presumably the code
+is asking for the correct attribute number.
+
+=item C<PMC *
+Parrot_set_attrib_by_str(Parrot_Interp interpreter, PMC *object,
+ STRING *attr, PMC *value)>
+
+Sets attribute with full qualified name C<attr> from C<object> to C<value>.
+
+*/
void
Parrot_set_attrib_by_num(Parrot_Interp interpreter, PMC *object,
1.40 +13 -2 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -w -r1.39 -r1.40
--- objects.t 3 Apr 2004 15:59:32 -0000 1.39
+++ objects.t 3 Apr 2004 20:44:43 -0000 1.40
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: objects.t,v 1.39 2004/04/03 15:59:32 leo Exp $
+# $Id: objects.t,v 1.40 2004/04/03 20:44:43 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 36;
+use Parrot::Test tests => 37;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -1091,4 +1091,15 @@
CODE
foo i
bar j
+OUTPUT
+
+output_like(<<'CODE', <<'OUTPUT', "addattribute duplicate");
+ newclass P1, "Foo"
+ addattribute P1, "i"
+ addattribute P1, "j"
+ addattribute P1, "i"
+ print "never\n"
+ end
+CODE
+/Attribute 'Foo(.*?i)?' already exists/
OUTPUT
1.56 +8 -1 parrot/vtable.tbl
Index: vtable.tbl
===================================================================
RCS file: /cvs/public/parrot/vtable.tbl,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -w -r1.55 -r1.56
--- vtable.tbl 23 Mar 2004 07:56:02 -0000 1.55
+++ vtable.tbl 3 Apr 2004 20:44:47 -0000 1.56
@@ -1,4 +1,4 @@
-# $Id: vtable.tbl,v 1.55 2004/03/23 07:56:02 leo Exp $
+# $Id: vtable.tbl,v 1.56 2004/04/03 20:44:47 leo Exp $
# [MAIN] #default section name
void init()
@@ -262,6 +262,13 @@
INTVAL does(STRING* method)
INTVAL isa(STRING* _class)
+
+PMC* get_attr(INTVAL idx)
+PMC* get_attr_str(STRING* idx)
+void set_attr(INTVAL idx, PMC* value)
+void set_attr_str(STRING* idx, PMC* value)
+
+PMC* get_class()
void freeze(visit_info* info)
void thaw (visit_info* info)
