cvsuser 04/02/26 09:10:31
Modified: ops object.ops
src objects.c
t/pmc objects.t
Log:
object fixes and some tests
Revision Changes Path
1.32 +1 -1 parrot/ops/object.ops
Index: object.ops
===================================================================
RCS file: /cvs/public/parrot/ops/object.ops,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -w -r1.31 -r1.32
--- object.ops 25 Feb 2004 23:49:55 -0000 1.31
+++ object.ops 26 Feb 2004 17:10:23 -0000 1.32
@@ -223,7 +223,7 @@
=cut
inline op class(out PMC, in PMC) {
- if (PObj_is_class_TEST($2))
+ if (PObj_is_object_TEST($2))
$1 = VTABLE_get_pmc_keyed_int(interpreter,
(PMC *)PMC_data($2), POD_CLASS);
else
1.45 +8 -8 parrot/src/objects.c
Index: objects.c
===================================================================
RCS file: /cvs/public/parrot/src/objects.c,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -w -r1.44 -r1.45
--- objects.c 26 Feb 2004 00:05:21 -0000 1.44
+++ objects.c 26 Feb 2004 17:10:27 -0000 1.45
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: objects.c,v 1.44 2004/02/26 00:05:21 scog Exp $
+$Id: objects.c,v 1.45 2004/02/26 17:10:27 leo Exp $
=head1 NAME
@@ -816,7 +816,7 @@
INTVAL attrib_count;
attrib_array = PMC_data(object);
attrib_count = VTABLE_elements(interpreter, attrib_array);
- if (attrib > attrib_count || attrib < 0) {
+ if (attrib >= attrib_count || attrib < POD_FIRST_ATTRIB) {
internal_exception(OUT_OF_BOUNDS, "No such attribute");
}
return VTABLE_get_pmc_keyed_int(interpreter, attrib_array, attrib);
@@ -834,7 +834,7 @@
INTVAL attrib_count;
attrib_array = PMC_data(object);
attrib_count = VTABLE_elements(interpreter, attrib_array);
- if (attrib > attrib_count || attrib < 0) {
+ if (attrib >= attrib_count || attrib < POD_FIRST_ATTRIB) {
internal_exception(OUT_OF_BOUNDS, "No such attribute");
}
VTABLE_set_pmc_keyed_int(interpreter, attrib_array, attrib, value);
1.26 +93 -7 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -w -r1.25 -r1.26
--- objects.t 26 Feb 2004 15:55:40 -0000 1.25
+++ objects.t 26 Feb 2004 17:10:31 -0000 1.26
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: objects.t,v 1.25 2004/02/26 15:55:40 scog Exp $
+# $Id: objects.t,v 1.26 2004/02/26 17:10:31 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 21;
+use Parrot::Test tests => 23;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -211,10 +211,21 @@
classname S0, P2 # object
print S0
print "\n"
+
+ class P3, P1
+ classname S0, P1 # class
+ print S0
+ print "\n"
+ class P3, P1
+ classname S0, P2 # object
+ print S0
+ print "\n"
end
CODE
Foo
Foo
+Foo
+Foo
OUTPUT
output_is(<<'CODE', <<'OUTPUT', "isa subclass");
@@ -404,10 +415,23 @@
find_type I0, "Foo"
new P2, I0
classoffset I1, P2, "Foo"
- add I2, I1, 6
new P3, .PerlInt
- setattribute P2, I2, P3
+ setattribute P2, I1, P3
+ end
+CODE
+/No such attribute/
+OUTPUT
+
+output_like(<<'CODE', <<'OUTPUT', "setting non-existant attribute - 1");
+ newclass P1, "Foo"
+ find_type I0, "Foo"
+ new P2, I0
+ classoffset I1, P2, "Foo"
+
+ new P3, .PerlInt
+ dec I1
+ setattribute P2, I1, P3
end
CODE
/No such attribute/
@@ -507,6 +531,68 @@
11
101
101
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "attribute values and subclassing 2");
+ newclass P1, "Foo"
+ # must add attributes before object instantion
+ addattribute P1, "i"
+ addattribute P1, "j"
+
+ newclass P2, "Bar" # or subclass P2, P1, "Bar" ???
+ addattribute P2, "k"
+ addattribute P2, "l"
+ addparent P2, P1
+
+ # instantiate a Bar object
+ find_type I1, "Bar"
+ new P3, I1
+
+ classoffset I3, P3, "Foo" # The parent class
+ # print I3 # don't assume anything about this offset
+ # print "\n"
+
+
+ set I0, I3 # is this always the first attribute?
+
+ new P10, .PerlString # set attribute values
+ set P10, "i\n"
+ setattribute P3, I0, P10
+ inc I0
+ new P10, .PerlString
+ set P10, "j\n"
+ setattribute P3, I0, P10
+ inc I0 # is that safe to assume
+ new P10, .PerlString
+ set P10, "k\n"
+ setattribute P3, I0, P10
+ inc I0
+ new P10, .PerlString
+ set P10, "l\n"
+ setattribute P3, I0, P10
+
+ getattribute P11, P3, I3
+ print P11
+ inc I3
+ getattribute P11, P3, I3
+ print P11
+ inc I3
+ getattribute P11, P3, I3
+ print P11
+ inc I3
+ getattribute P11, P3, I3
+ print P11
+
+ classname S0, P3
+ print S0
+ print "\n"
+ end
+CODE
+i
+j
+k
+l
+Bar
OUTPUT
