cvsuser 04/03/03 01:31:27
Modified: classes pmc2c2.pl
t/pmc objects.t
Log:
delegate object vtables
* hack to get inheritance object isa delegate
* test
Revision Changes Path
1.9 +18 -5 parrot/classes/pmc2c2.pl
Index: pmc2c2.pl
===================================================================
RCS file: /cvs/public/parrot/classes/pmc2c2.pl,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -w -r1.8 -r1.9
--- pmc2c2.pl 22 Feb 2004 17:48:41 -0000 1.8
+++ pmc2c2.pl 3 Mar 2004 09:31:24 -0000 1.9
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: pmc2c2.pl,v 1.8 2004/02/22 17:48:41 mikescott Exp $
+# $Id: pmc2c2.pl,v 1.9 2004/03/03 09:31:24 leo Exp $
=head1 NAME
@@ -413,7 +413,20 @@
}
}
unless (exists $self->{super}{$meth}) {
- $self->{super}{$meth} = 'default';
+ # XXX this is a quick hack to get the inheritance
+ # ParrotClass isa delegate
+ #
+ # delegate has everything autogenerated, so these
+ # methods aren't seen and not inherited properly
+ #
+ # the correct way would be to look at
+ # $self->implements but when dumping there isn't
+ # a $class object
+ $self->{super}{$meth} =
+ $self->{class} eq 'ParrotObject' ||
+ $self->{class} eq 'ParrotClass' ?
+ 'delegate' :
+ 'default';
}
}
}
1.30 +67 -2 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -w -r1.29 -r1.30
--- objects.t 27 Feb 2004 10:10:15 -0000 1.29
+++ objects.t 3 Mar 2004 09:31:27 -0000 1.30
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: objects.t,v 1.29 2004/02/27 10:10:15 leo Exp $
+# $Id: objects.t,v 1.30 2004/03/03 09:31:27 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 25;
+use Parrot::Test tests => 26;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -817,3 +817,68 @@
m
OUTPUT
+output_is(<<'CODE', <<'OUTPUT', "overriden vtables");
+ newclass P1, "Foo"
+ find_global P2, "set_i"
+ store_global "Foo", "__set_integer_native", P2
+ find_global P2, "add"
+ store_global "Foo", "__add", P2
+ find_global P2, "get_s"
+ store_global "Foo", "__get_string", P2
+ # must add attributes before object instantiation
+ addattribute P1, ".i"
+
+ find_type I1, "Foo"
+ new P3, I1
+ set P3, 1
+ new P4, I1
+ set P4, 1
+ new P5, I1
+
+ add P5, P3, P4
+ # the print below calls __get_string
+ print P5
+ print "\n"
+ set P4, 41
+ add P5, P3, P4
+ print P5
+ print "\n"
+ end
+
+.pcc_sub set_i:
+ print "in set_integer\n"
+ classoffset I0, P2, "Foo"
+ new P6, .PerlInt
+ set P6, I5
+ setattribute P2, I0, P6
+ invoke P1
+.pcc_sub add:
+ print "in add\n"
+ classoffset I0, P2, "Foo"
+ getattribute P10, P2, I0
+ getattribute P11, P5, I0
+ new P12, .PerlInt
+ add P12, P10, P11
+ setattribute P6, I0, P12
+ invoke P1
+.pcc_sub get_s:
+ print "in get_string\n"
+ classoffset I0, P2, "Foo"
+ getattribute P10, P2, I0
+ set S5, P10
+ set I0, P10
+ ne I0, 2, no_2
+ set S5, "two"
+no_2:
+ invoke P1
+CODE
+in set_integer
+in set_integer
+in add
+in get_string
+two
+in set_integer
+in add
+in get_string
+42
+OUTPUT
