Author: chromatic
Date: Sun Apr 15 21:45:33 2007
New Revision: 18233
Modified:
trunk/src/ops/object.ops
trunk/src/pmc/class.pmc
trunk/t/oo/ops.t
Log:
Add tests for addattribute_p_s op. This should be backwards-compatible with
old-style classes.
Note that it throws an invalid operation exception when used on non-classes.
There may be some corner cases here, but this is a temporary differentiator
until old-style classes go away.
Modified: trunk/src/ops/object.ops
==============================================================================
--- trunk/src/ops/object.ops (original)
+++ trunk/src/ops/object.ops Sun Apr 15 21:45:33 2007
@@ -530,7 +530,17 @@
=cut
inline op addattribute(invar PMC, in STR) :object_classes {
- Parrot_add_attribute(interp, $1, $2);
+ STRING *class_name = string_from_const_cstring(interp, "Class", 0);
+ STRING *pclass_name = string_from_const_cstring(interp, "ParrotClass", 0);
+
+ if (VTABLE_isa(interp, $1, class_name))
+ VTABLE_add_attribute(interp, $1, $2, PMCNULL);
+ else if (VTABLE_isa(interp, $1, pclass_name))
+ Parrot_add_attribute(interp, $1, $2);
+ else
+ real_exception(interp, NULL, INVALID_OPERATION,
+ "Cannot add attribute to non-class" );
+
goto NEXT();
}
Modified: trunk/src/pmc/class.pmc
==============================================================================
--- trunk/src/pmc/class.pmc (original)
+++ trunk/src/pmc/class.pmc Sun Apr 15 21:45:33 2007
@@ -261,7 +261,7 @@
Parrot_PCCINVOKE(interp, class->namespace,
string_from_const_cstring(interp, "set_class", 0),
"P->", self);
-
+
/* Initialize resolve_method. */
if (VTABLE_exists_keyed_str(interp, info,
string_from_const_cstring(interp, "resolve_method", 0))) {
Modified: trunk/t/oo/ops.t
==============================================================================
--- trunk/t/oo/ops.t (original)
+++ trunk/t/oo/ops.t Sun Apr 15 21:45:33 2007
@@ -6,7 +6,7 @@
use warnings;
use lib qw( . lib ../lib ../../lib );
use Test::More;
-use Parrot::Test tests => 5;
+use Parrot::Test tests => 6;
=head1 NAME
@@ -47,7 +47,7 @@
$P1 = inspect $P0
print "ok 1 - inspect_p_p op executed\n"
-
+
$I0 = elements $P1
if $I0 == 6 goto ok_2
print "not "
@@ -68,7 +68,7 @@
$P1 = inspect $P0, 'name'
say $P1
print "ok 1 - inspect_p_p_s with $3='name'\n"
-
+
$P1 = inspect $P0, 'attributes'
$I0 = elements $P1
if $I0 == 1 goto ok_2
@@ -88,10 +88,10 @@
$P4 = new 'String'
$P4 = 'Monkey'
$P0['name'] = $P4
-
+
$P1 = new 'Class', $P0
print "ok 1 - created new class named Monkey\n"
-
+
push_eh nok_2
$P2 = get_class 'Monkey'
clear_eh
@@ -100,7 +100,7 @@
print "not "
ok_2:
print "ok 2 - get_class found a class\n"
-
+
$P3 = $P2.'inspect'('name')
print $P3
print "\nok 3 - got name of found class\n"
@@ -118,10 +118,10 @@
$P4 = new 'String'
$P4 = 'Monkey'
$P0['name'] = $P4
-
+
$P1 = new 'Class', $P0
print "ok 1 - created new class named Monkey\n"
-
+
push_eh nok_2
$P2 = get_class [ 'Monkey' ]
clear_eh
@@ -130,7 +130,7 @@
print "not "
ok_2:
print "ok 2 - get_class with a Key found a class\n"
-
+
$P3 = $P2.'inspect'('name')
print $P3
print "\nok 3 - got name of found class\n"
@@ -144,7 +144,7 @@
print "not "
ok_4:
print "ok 4 - get_class with a NameSpace found a class\n"
-
+
$P3 = $P2.'inspect'('name')
print $P3
print "\nok 5 - got name of found class\n"
@@ -159,6 +159,31 @@
ok 5 - got name of found class
OUT
+pir_output_like( <<'CODE', <<'OUT', 'addattribute_p_s' );
+.sub main :main
+ $P0 = new 'Class'
+ addattribute $P0, 'foo'
+
+ $P1 = $P0.'new'()
+
+ $P2 = new 'Integer'
+ $P2 = 100
+ setattribute $P1, 'foo', $P2
+ getattribute $P2, $P1, 'foo'
+
+ print $P2
+ print "\n"
+
+ $P0 = new 'Hash'
+ addattribute $P0, 'oops'
+ print "Not here!\n"
+.end
+CODE
+/100
+Cannot add attribute to non-class
+current instr\.: 'main'/
+OUT
+
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
