cvsuser 04/11/22 04:07:23
Modified: src inter_run.c
t/pmc object-meths.t
Log:
fix register keys in method calls
Revision Changes Path
1.20 +26 -4 parrot/src/inter_run.c
Index: inter_run.c
===================================================================
RCS file: /cvs/public/parrot/src/inter_run.c,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- inter_run.c 20 Nov 2004 08:49:17 -0000 1.19
+++ inter_run.c 22 Nov 2004 12:07:22 -0000 1.20
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: inter_run.c,v 1.19 2004/11/20 08:49:17 leo Exp $
+$Id: inter_run.c,v 1.20 2004/11/22 12:07:22 leo Exp $
=head1 NAME
@@ -209,12 +209,14 @@
const char *p;
PMC *p3 = PMCNULL;
int clear_p3, need_p3, max;
+ PMC *arg;
for (i = 0; i < 4; i++) {
next[i] = 5;
count[i] = 0;
}
+ bp = interpreter->ctx.bp;
ret_c = new_ret_continuation_pmc(interpreter, NULL);
dest = VTABLE_invoke(interpreter, sub, NULL);
interpreter->ctx.current_sub = REG_PMC(0) = sub;
@@ -281,11 +283,31 @@
REG_STR(next[1]++) = va_arg(ap, STRING*);
break;
case 'P': /* REG_PMC */
+ arg = va_arg(ap, PMC*);
if (next[2] == 16)
- VTABLE_set_pmc_keyed_int(interpreter,
- p3, i++, va_arg(ap, PMC*));
+ VTABLE_set_pmc_keyed_int(interpreter, p3, i++, arg);
else
- REG_PMC(next[2]++) = va_arg(ap, PMC*);
+ REG_PMC(next[2]++) = arg;
+ /*
+ * if this is a Key PMC with registers, pass on these
+ * registers.
+ * XXX make a distinct 'K' signature ?
+ */
+ if (arg->vtable->base_type == enum_class_Key) {
+ while (arg) {
+ UINTVAL flags = PObj_get_FLAGS(arg);
+ if (flags & KEY_register_FLAG) {
+ INTVAL n = PMC_int_val(arg);
+ if (flags & KEY_integer_FLAG)
+ REG_INT(n) = BP_REG_INT(bp, n);
+ else if (flags & KEY_pmc_FLAG)
+ REG_PMC(n) = BP_REG_PMC(bp, n);
+ else if (flags & KEY_string_FLAG)
+ REG_STR(n) = BP_REG_STR(bp, n);
+ }
+ arg = key_next(interpreter, arg);
+ }
+ }
break;
case 'N': /* REG_NUM */
if (next[3] == 16)
1.23 +32 -2 parrot/t/pmc/object-meths.t
Index: object-meths.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/object-meths.t,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -r1.22 -r1.23
--- object-meths.t 20 Nov 2004 08:49:17 -0000 1.22
+++ object-meths.t 22 Nov 2004 12:07:23 -0000 1.23
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: object-meths.t,v 1.22 2004/11/20 08:49:17 leo Exp $
+# $Id: object-meths.t,v 1.23 2004/11/22 12:07:23 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 22;
+use Parrot::Test tests => 23;
use Test::More;
output_like(<<'CODE', <<'OUTPUT', "callmethod - unknown method");
@@ -745,3 +745,33 @@
CODE
ok
OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "Bug in method calling with nonconst keys");
+##PIR##
+.sub _main
+ newclass $P0, "Foo"
+
+ find_type $I0, "Foo"
+ new $P1, $I0
+
+ $I1 = $P1["foo"]
+
+ $S0 = "foo"
+ $I1 = $P1[$S0]
+
+ end
+.end
+
+.namespace ["Foo"]
+
+.sub __get_integer_keyed
+ .param pmc key
+ print "Key = "
+ print key
+ print "\n"
+ .return(0)
+.end
+CODE
+Key = foo
+Key = foo
+OUTPUT
