[svn:parrot] r42138 - in trunk: src/ops t/op
chromatic at svn.parrot.org
chromatic at svn.parrot.org
Tue Oct 27 20:14:59 UTC 2009
Author: chromatic
Date: Tue Oct 27 20:14:56 2009
New Revision: 42138
URL: https://trac.parrot.org/parrot/changeset/42138
Log:
[op] Updated experimental fetch op to take a type argument, not a PMC to clone,
per pmichaud's updated tests.
Modified:
trunk/src/ops/experimental.ops
trunk/t/op/fetch.t
Modified: trunk/src/ops/experimental.ops
==============================================================================
--- trunk/src/ops/experimental.ops Tue Oct 27 18:15:14 2009 (r42137)
+++ trunk/src/ops/experimental.ops Tue Oct 27 20:14:56 2009 (r42138)
@@ -78,12 +78,10 @@
=over 4
-=item B<fetch>(out PMC, in PMC, in KEY, in PMC)
+=item B<fetch>(out PMC, in PMC, in PMC, in PMC)
Fetches a value from $2, keyed by $3 into $1. If the resulting PMC is PMCNULL,
-clones $4 and assigns the result to $1 instead.
-
-=item B<fetch>(out PMC, in PMC, in PMC, in PMC)
+uses the type in $4 to create and return a new PMC.
=item B<fetch>(out PMC, in PMC, in INT, in PMC)
@@ -93,28 +91,64 @@
=cut
-inline op fetch(out PMC, in PMC, in KEY, in PMC) :base_core {
- $1 = VTABLE_get_pmc_keyed(interp, $2, $3);
- if (PMC_IS_NULL($1))
- $1 = VTABLE_clone(interp, $4);
-}
-
inline op fetch(out PMC, in PMC, in PMC, in PMC) :base_core {
$1 = VTABLE_get_pmc_keyed(interp, $2, $3);
- if (PMC_IS_NULL($1))
- $1 = VTABLE_clone(interp, $4);
+ if (PMC_IS_NULL($1)) {
+ PMC * const classobj = Parrot_oo_get_class(interp, $4);
+ if (!PMC_IS_NULL(classobj))
+ $1 = VTABLE_instantiate(interp, classobj, PMCNULL);
+ else {
+ const INTVAL type = pmc_type_p(interp, $4);
+ if (type <= 0) {
+ opcode_t *dest = Parrot_ex_throw_from_op_args(
+ interp, expr NEXT(), EXCEPTION_NO_CLASS,
+ "Class '%Ss' not found", VTABLE_get_repr(interp, $4));
+ goto ADDRESS(dest);
+ }
+
+ $1 = pmc_new(interp, type);
+ }
+ }
}
inline op fetch(out PMC, in PMC, in INT, in PMC) :base_core {
$1 = VTABLE_get_pmc_keyed_int(interp, $2, $3);
- if (PMC_IS_NULL($1))
- $1 = VTABLE_clone(interp, $4);
+ if (PMC_IS_NULL($1)) {
+ PMC * const classobj = Parrot_oo_get_class(interp, $4);
+ if (!PMC_IS_NULL(classobj))
+ $1 = VTABLE_instantiate(interp, classobj, PMCNULL);
+ else {
+ const INTVAL type = pmc_type_p(interp, $4);
+ if (type <= 0) {
+ opcode_t *dest = Parrot_ex_throw_from_op_args(
+ interp, expr NEXT(), EXCEPTION_NO_CLASS,
+ "Class '%Ss' not found", VTABLE_get_repr(interp, $4));
+ goto ADDRESS(dest);
+ }
+
+ $1 = pmc_new(interp, type);
+ }
+ }
}
inline op fetch(out PMC, in PMC, in STR, in PMC) :base_core {
$1 = VTABLE_get_pmc_keyed_str(interp, $2, $3);
- if (PMC_IS_NULL($1))
- $1 = VTABLE_clone(interp, $4);
+ if (PMC_IS_NULL($1)) {
+ PMC * const classobj = Parrot_oo_get_class(interp, $4);
+ if (!PMC_IS_NULL(classobj))
+ $1 = VTABLE_instantiate(interp, classobj, PMCNULL);
+ else {
+ const INTVAL type = pmc_type_p(interp, $4);
+ if (type <= 0) {
+ opcode_t *dest = Parrot_ex_throw_from_op_args(
+ interp, expr NEXT(), EXCEPTION_NO_CLASS,
+ "Class '%Ss' not found", VTABLE_get_repr(interp, $4));
+ goto ADDRESS(dest);
+ }
+
+ $1 = pmc_new(interp, type);
+ }
+ }
}
=head1 COPYRIGHT
Modified: trunk/t/op/fetch.t
==============================================================================
--- trunk/t/op/fetch.t Tue Oct 27 18:15:14 2009 (r42137)
+++ trunk/t/op/fetch.t Tue Oct 27 20:14:56 2009 (r42138)
@@ -19,115 +19,85 @@
.sub 'main' :main
.include 'test_more.pir'
- plan(18)
+ plan(17)
test_fetch_keyed_pmc()
test_fetch_keyed_int()
- test_fetch_keyed_string()
+ test_fetch_keyed_str()
# END_OF_TESTS
.end
.sub 'test_fetch_keyed_int'
diag( 'test_fetch_keyed_int' )
$P0 = new [ 'Hash' ]
- $P1 = new [ 'Integer' ]
- $P1 = 111
+ $P1 = box 111
$P0[1] = $P1
$P0[3] = $P1
- $P2 = new [ 'Integer' ]
- $P2 = 222
-
- $P3 = fetch $P0, 1, $P2
+ $P3 = fetch $P0, 1, [ 'Integer' ]
is( $P3, 111, 'fetch should return existing element unmodified' )
$P1 = 123
is( $P3, 123, '... the exact PMC itself' )
- $P3 = fetch $P0, 3, $P2
+ $P3 = fetch $P0, 3, [ 'Integer' ]
is( $P3, 123, '... even if stored in multiple locations' )
- $P3 = fetch $P0, 2, $P2
- is( $P3, 222, 'fetch should return default PMC if keyed PMC is not there' )
-
- $P2 = 234
- is( $P3, 222, '... a clone of the default PMC' )
+ $P3 = fetch $P0, 2, [ 'Integer' ]
+ is( $P3, 0, 'fetch should create new PMC if not-existent' )
+ isa_ok( $P3, 'Integer', 'new PMC should have type Integer' )
.end
-.sub 'test_fetch_keyed_string'
- diag( 'test_fetch_keyed_string' )
- $P0 = new [ 'NameSpace' ]
- $P1 = new [ 'Integer' ]
- $P1 = 111
- $P0['foo'] = $P1
- $P0['bar'] = $P1
-
- $P2 = new [ 'Integer' ]
- $P2 = 222
+.sub 'test_fetch_keyed_str'
+ diag( 'test_fetch_keyed_str' )
+ $P0 = new [ 'Hash' ]
+ $P1 = box 111
+ $P0['one'] = $P1
+ $P0['three'] = $P1
- $P3 = fetch $P0, 'foo', $P2
+ $P3 = fetch $P0, 'one', [ 'Integer' ]
is( $P3, 111, 'fetch should return existing element unmodified' )
- $P1 = 123
+ $P1 = 123
is( $P3, 123, '... the exact PMC itself' )
- $S0 = 'bar'
- $P3 = fetch $P0, $S0, $P2
+ $P3 = fetch $P0, 'three', [ 'Integer' ]
is( $P3, 123, '... even if stored in multiple locations' )
- $P3 = fetch $P0, 'baz', $P2
- is( $P3, 222, 'fetch should return default PMC if keyed PMC is not there' )
-
- $S0 = 'quux'
- $P3 = fetch $P0, $S0, $P2
- is( $P3, 222, 'fetch should return default PMC if keyed PMC is not there' )
-
- $P2 = 234
- is( $P3, 222, '... a clone of the default PMC' )
+ $P3 = fetch $P0, 'two', [ 'Integer' ]
+ is( $P3, 0, 'fetch should create new PMC if not-existent' )
+ isa_ok( $P3, 'Integer', 'new PMC should have type Integer' )
.end
.sub 'test_fetch_keyed_pmc'
diag( 'test_fetch_keyed_pmc' )
$P0 = new [ 'Hash' ]
- $P1 = new [ 'Integer' ]
- $P1 = 111
+ $P1 = box 111
.local pmc str_key
- str_key = new [ 'String' ]
- str_key = 'foo'
-
+ str_key = box 'foo'
$P0[str_key] = $P1
.local pmc int_key
- int_key = new [ 'Integer' ]
- int_key = 435
+ int_key = box 435
$P0[int_key] = $P1
- $P2 = new [ 'Integer' ]
- $P2 = 222
-
- $P3 = fetch $P0, str_key, $P2
+ $P3 = fetch $P0, str_key, [ 'String' ]
is( $P3, 111, 'fetch should return existing element unmodified' )
$P1 = 123
is( $P3, 123, '... the exact PMC itself' )
- $P3 = fetch $P0, int_key, $P2
+ $P3 = fetch $P0, int_key, [ 'String' ]
is( $P3, 123, '... even if stored in multiple locations' )
str_key = 'baz'
-
- $P3 = fetch $P0, str_key, $P2
- is( $P3, 222, 'fetch should return default PMC if keyed PMC is not there' )
-
- $P3 = 234
- is( $P2, 222, '... a clone of the default PMC' )
+ $P3 = fetch $P0, str_key, [ 'String' ]
+ is( $P3, '', 'fetch should return new PMC if keyed PMC is not there' )
+ isa_ok( $P3, 'String', 'new PMC should have given type' )
int_key = 789
-
- $P3 = fetch $P0, int_key, $P2
- is( $P3, 222, 'fetch should return default PMC if keyed PMC is not there' )
-
- $P2 = 234
- is( $P3, 222, '... a clone of the default PMC' )
+ $P3 = fetch $P0, str_key, [ 'String' ]
+ is( $P3, '', 'fetch should return new PMC if keyed PMC is not there' )
+ isa_ok( $P3, 'String', 'new PMC should have given type' )
.end
# Local Variables:
More information about the parrot-commits
mailing list