[svn:parrot] r40833 - in branches/context_pmc3: config/init/hints include/parrot src src/gc src/ops src/pmc t/library t/op t/pmc
bacek at svn.parrot.org
bacek at svn.parrot.org
Thu Aug 27 22:16:18 UTC 2009
Author: bacek
Date: Thu Aug 27 22:16:16 2009
New Revision: 40833
URL: https://trac.parrot.org/parrot/changeset/40833
Log:
Bring branch up-to-date with trunk.
Modified:
branches/context_pmc3/config/init/hints/dec_osf.pm
branches/context_pmc3/config/init/hints/dragonfly.pm
branches/context_pmc3/config/init/hints/hpux.pm
branches/context_pmc3/config/init/hints/irix.pm
branches/context_pmc3/config/init/hints/netbsd.pm
branches/context_pmc3/config/init/hints/openbsd.pm
branches/context_pmc3/config/init/hints/solaris.pm
branches/context_pmc3/include/parrot/pmc.h
branches/context_pmc3/src/gc/mark_sweep.c
branches/context_pmc3/src/oo.c
branches/context_pmc3/src/ops/set.ops
branches/context_pmc3/src/pmc.c
branches/context_pmc3/src/pmc/fixedfloatarray.pmc
branches/context_pmc3/t/library/rand.t
branches/context_pmc3/t/op/gc.t
branches/context_pmc3/t/pmc/default.t
branches/context_pmc3/t/pmc/parrotinterpreter.t
branches/context_pmc3/t/pmc/pmc.t
branches/context_pmc3/t/pmc/undef.t
Modified: branches/context_pmc3/config/init/hints/dec_osf.pm
==============================================================================
--- branches/context_pmc3/config/init/hints/dec_osf.pm Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/config/init/hints/dec_osf.pm Thu Aug 27 22:16:16 2009 (r40833)
@@ -11,7 +11,7 @@
# Tru64
my $ccflags = $conf->data->get('ccflags');
- if ( $ccflags !~ /-pthread/ ) {
+ if ( $ccflags !~ /-pthread\b/ ) {
$ccflags .= ' -pthread';
}
if ( $ccflags !~ /-D_REENTRANT/ ) {
@@ -24,7 +24,7 @@
$conf->data->set( ccflags => $ccflags );
my $libs = $conf->data->get('libs');
- if ( $libs !~ /-lpthread/ ) {
+ if ( $libs !~ /-lpthread\b/ ) {
$libs .= ' -lpthread';
}
$conf->data->set( libs => $libs );
@@ -37,7 +37,7 @@
}
my $linkflags = $conf->data->get('linkflags');
- if ( $linkflags !~ /-expect_unresolved/ ) {
+ if ( $linkflags !~ /-expect_unresolved\b/ ) {
$linkflags = "-expect_unresolved '*' -O4 -msym -std $linkflags";
$conf->data->set( linkflags => $linkflags );
}
Modified: branches/context_pmc3/config/init/hints/dragonfly.pm
==============================================================================
--- branches/context_pmc3/config/init/hints/dragonfly.pm Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/config/init/hints/dragonfly.pm Thu Aug 27 22:16:16 2009 (r40833)
@@ -13,7 +13,7 @@
my $version = $conf->option_or_data('VERSION');
my $libs = $conf->data->get('libs');
- $libs .= ' -pthread' unless $libs =~ /pthread/;
+ $libs .= ' -pthread' unless $libs =~ /pthread\b/;
$conf->data->set(
libs => $libs,
Modified: branches/context_pmc3/config/init/hints/hpux.pm
==============================================================================
--- branches/context_pmc3/config/init/hints/hpux.pm Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/config/init/hints/hpux.pm Thu Aug 27 22:16:16 2009 (r40833)
@@ -10,7 +10,7 @@
my ( $self, $conf ) = @_;
my $libs = $conf->data->get('libs');
- if ( $libs !~ /-lpthread/ ) {
+ if ( $libs !~ /-lpthread\b/ ) {
$libs .= ' -lpthread';
}
Modified: branches/context_pmc3/config/init/hints/irix.pm
==============================================================================
--- branches/context_pmc3/config/init/hints/irix.pm Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/config/init/hints/irix.pm Thu Aug 27 22:16:16 2009 (r40833)
@@ -21,7 +21,7 @@
$conf->data->set( ccflags => $ccflags );
my $libs = $conf->data->get('libs');
- if ( $libs !~ /-lpthread/ ) {
+ if ( $libs !~ /-lpthread\b/ ) {
$libs .= ' -lpthread';
}
$conf->data->set( libs => $libs );
Modified: branches/context_pmc3/config/init/hints/netbsd.pm
==============================================================================
--- branches/context_pmc3/config/init/hints/netbsd.pm Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/config/init/hints/netbsd.pm Thu Aug 27 22:16:16 2009 (r40833)
@@ -10,13 +10,13 @@
my ( $self, $conf ) = @_;
my $ccflags = $conf->data->get('ccflags');
- if ( $ccflags !~ /-pthread/ ) {
+ if ( $ccflags !~ /-pthread\b/ ) {
$ccflags .= ' -pthread';
}
$conf->data->set( ccflags => $ccflags );
my $libs = $conf->data->get('libs');
- if ( $libs !~ /-lpthread/ ) {
+ if ( $libs !~ /-lpthread\b/ ) {
$libs .= ' -lpthread';
}
$conf->data->set( libs => $libs );
Modified: branches/context_pmc3/config/init/hints/openbsd.pm
==============================================================================
--- branches/context_pmc3/config/init/hints/openbsd.pm Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/config/init/hints/openbsd.pm Thu Aug 27 22:16:16 2009 (r40833)
@@ -12,13 +12,13 @@
my $share_ext = $conf->option_or_data('share_ext');
my $version = $conf->option_or_data('VERSION');
my $ccflags = $conf->data->get('ccflags');
- if ( $ccflags !~ /-pthread/ ) {
+ if ( $ccflags !~ /-pthread\b/ ) {
$ccflags .= ' -pthread';
}
$conf->data->set( ccflags => $ccflags );
my $libs = $conf->data->get('libs');
- if ( $libs !~ /-lpthread/ ) {
+ if ( $libs !~ /-lpthread\b/ ) {
$libs .= ' -lpthread';
}
$conf->data->set(
Modified: branches/context_pmc3/config/init/hints/solaris.pm
==============================================================================
--- branches/context_pmc3/config/init/hints/solaris.pm Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/config/init/hints/solaris.pm Thu Aug 27 22:16:16 2009 (r40833)
@@ -10,7 +10,7 @@
my ( $self, $conf ) = @_;
my $libs = $conf->data->get('libs');
- if ( $libs !~ /-lpthread/ ) {
+ if ( $libs !~ /-lpthread\b/ ) {
$libs .= ' -lpthread';
}
if ( $libs !~ /-lrt\b/ ) {
Modified: branches/context_pmc3/include/parrot/pmc.h
==============================================================================
--- branches/context_pmc3/include/parrot/pmc.h Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/include/parrot/pmc.h Thu Aug 27 22:16:16 2009 (r40833)
@@ -54,6 +54,11 @@
__attribute__nonnull__(1);
PARROT_EXPORT
+void Parrot_pmc_destroy(PARROT_INTERP, ARGIN(PMC *pmc))
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+
+PARROT_EXPORT
INTVAL PMC_is_null(SHIM_INTERP, ARGIN_NULLOK(const PMC *pmc));
PARROT_EXPORT
@@ -149,6 +154,9 @@
|| PARROT_ASSERT_ARG(pmc)
#define ASSERT_ARGS_Parrot_create_mro __attribute__unused__ int _ASSERT_ARGS_CHECK = \
PARROT_ASSERT_ARG(interp)
+#define ASSERT_ARGS_Parrot_pmc_destroy __attribute__unused__ int _ASSERT_ARGS_CHECK = \
+ PARROT_ASSERT_ARG(interp) \
+ || PARROT_ASSERT_ARG(pmc)
#define ASSERT_ARGS_PMC_is_null __attribute__unused__ int _ASSERT_ARGS_CHECK = 0
#define ASSERT_ARGS_pmc_new __attribute__unused__ int _ASSERT_ARGS_CHECK = \
PARROT_ASSERT_ARG(interp)
Modified: branches/context_pmc3/src/gc/mark_sweep.c
==============================================================================
--- branches/context_pmc3/src/gc/mark_sweep.c Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/src/gc/mark_sweep.c Thu Aug 27 22:16:16 2009 (r40833)
@@ -776,27 +776,7 @@
if (PObj_needs_early_gc_TEST(p))
--arena_base->num_early_gc_PMCs;
- if (PObj_active_destroy_TEST(p))
- VTABLE_destroy(interp, pmc);
-
- if (PMC_data(pmc) && pmc->vtable->attr_size) {
-#if GC_USE_FIXED_SIZE_ALLOCATOR
- Parrot_gc_free_pmc_attributes(interp, pmc, pmc->vtable->attr_size);
-#else
- mem_sys_free(PMC_data(pmc));
- PMC_data(pmc) = NULL;
-#endif
- }
- else {
- PMC_data(pmc) = NULL;
- }
-
-#ifndef NDEBUG
-
- pmc->vtable = (VTABLE *)0xdeadbeef;
-
-#endif
-
+ Parrot_pmc_destroy(interp, pmc);
}
Modified: branches/context_pmc3/src/oo.c
==============================================================================
--- branches/context_pmc3/src/oo.c Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/src/oo.c Thu Aug 27 22:16:16 2009 (r40833)
@@ -291,9 +291,8 @@
/* Flag that it is an object */
PObj_is_object_SET(cloned);
- /* Now create the underlying structure, and clone attributes list.class. */
- cloned_guts = mem_allocate_typed(Parrot_Object_attributes);
- PMC_data(cloned) = cloned_guts;
+ /* Now clone attributes list.class. */
+ cloned_guts = (Parrot_Object_attributes *) PMC_data(cloned);
cloned_guts->_class = obj->_class;
cloned_guts->attrib_store = NULL;
cloned_guts->attrib_store = VTABLE_clone(interp, obj->attrib_store);
Modified: branches/context_pmc3/src/ops/set.ops
==============================================================================
--- branches/context_pmc3/src/ops/set.ops Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/src/ops/set.ops Thu Aug 27 22:16:16 2009 (r40833)
@@ -500,8 +500,7 @@
PMC * const meta = VTABLE_getprops(interp, $1);
/* avoid leaks and unreachable memory by destroying the destination PMC */
- if (PObj_active_destroy_TEST($1))
- VTABLE_destroy(interp, $1);
+ Parrot_pmc_destroy(interp, $1);
/* the source PMC knows how to clone itself, but we must reuse the
* destination header */
@@ -509,6 +508,7 @@
/* don't let the clone's destruction destroy the destination's data */
PObj_active_destroy_CLEAR(clone);
+ PMC_data(clone) = NULL;
PMC_metadata(clone) = NULL;
PMC_next_for_GC(clone) = NULL;
PMC_sync(clone) = NULL;
Modified: branches/context_pmc3/src/pmc.c
==============================================================================
--- branches/context_pmc3/src/pmc.c Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/src/pmc.c Thu Aug 27 22:16:16 2009 (r40833)
@@ -91,6 +91,54 @@
/*
+=item C<void Parrot_pmc_destroy(PARROT_INTERP, PMC *pmc)>
+
+Destroy a PMC. Call his destroy vtable function if needed, and deallocate
+his attributes if they are automatically allocated.
+
+For internal usage of the PMC handling functions and garbage collection
+subsystem.
+
+=cut
+
+*/
+
+PARROT_EXPORT
+void
+Parrot_pmc_destroy(PARROT_INTERP, ARGIN(PMC *pmc))
+{
+ ASSERT_ARGS(Parrot_pmc_destroy)
+
+ if (PObj_active_destroy_TEST(pmc)) {
+ VTABLE_destroy(interp, pmc);
+ /* Prevent repeated calls. */
+ PObj_active_destroy_CLEAR(pmc);
+ }
+
+ if (pmc->vtable->attr_size) {
+ if (PMC_data(pmc)) {
+#if GC_USE_FIXED_SIZE_ALLOCATOR
+ Parrot_gc_free_pmc_attributes(interp, pmc, pmc->vtable->attr_size);
+#else
+ mem_sys_free(PMC_data(pmc));
+ PMC_data(pmc) = NULL;
+#endif
+ }
+ }
+ else {
+ PMC_data(pmc) = NULL;
+ }
+
+#ifndef NDEBUG
+
+ pmc->vtable = (VTABLE *)0xdeadbeef;
+
+#endif
+
+}
+
+/*
+
=item C<PMC * pmc_new(PARROT_INTERP, INTVAL base_type)>
Creates a new PMC of type C<base_type> (which is an index into the list of PMC
@@ -218,26 +266,17 @@
/* Singleton/const PMCs/types are not eligible */
check_pmc_reuse_flags(interp, pmc->vtable->flags, new_vtable->flags);
- /* Does the old PMC need any resources freed? */
- if (PObj_active_destroy_TEST(pmc))
- VTABLE_destroy(interp, pmc);
+ /* Free the old PMC resources. */
+ Parrot_pmc_destroy(interp, pmc);
PObj_flags_SETTO(pmc, PObj_is_PMC_FLAG | new_flags);
/* Set the right vtable */
pmc->vtable = new_vtable;
- if (PMC_data(pmc) && pmc->vtable->attr_size) {
-#if GC_USE_FIXED_SIZE_ALLOCATOR
- Parrot_gc_free_pmc_attributes(interp, pmc, pmc->vtable->attr_size);
-#else
- mem_sys_free(PMC_data(pmc));
-#endif
- }
-
if (new_vtable->attr_size) {
#if GC_USE_FIXED_SIZE_ALLOCATOR
- Parrot_gc_allocate_pmc_attributes(interp, pmc, pmc->vtable->attr_size);
+ Parrot_gc_allocate_pmc_attributes(interp, pmc, new_vtable->attr_size);
#else
PMC_data(pmc) = mem_sys_allocate_zeroed(new_vtable->attr_size);
#endif
@@ -280,15 +319,23 @@
/* Singleton/const PMCs/types are not eligible */
check_pmc_reuse_flags(interp, pmc->vtable->flags, new_vtable->flags);
- /* Does the old PMC need any resources freed? */
- if (PObj_active_destroy_TEST(pmc))
- VTABLE_destroy(interp, pmc);
+ Parrot_pmc_destroy(interp, pmc);
PObj_flags_SETTO(pmc, PObj_is_PMC_FLAG | new_flags);
/* Set the right vtable */
pmc->vtable = new_vtable;
+ if (new_vtable->attr_size) {
+#if GC_USE_FIXED_SIZE_ALLOCATOR
+ Parrot_gc_allocate_pmc_attributes(interp, pmc, new_vtable->attr_size);
+#else
+ PMC_data(pmc) = mem_sys_allocate_zeroed(new_vtable->attr_size);
+#endif
+}
+ else
+ PMC_data(pmc) = NULL;
+
return pmc;
}
Modified: branches/context_pmc3/src/pmc/fixedfloatarray.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/fixedfloatarray.pmc Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/src/pmc/fixedfloatarray.pmc Thu Aug 27 22:16:16 2009 (r40833)
@@ -31,19 +31,6 @@
=over 4
-=item C<void init()>
-
-Initializes the array.
-
-=cut
-
-*/
-
- VTABLE void init() {
- }
-
-/*
-
=item C<void destroy()>
Destroys the array.
Modified: branches/context_pmc3/t/library/rand.t
==============================================================================
--- branches/context_pmc3/t/library/rand.t Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/t/library/rand.t Thu Aug 27 22:16:16 2009 (r40833)
@@ -1,16 +1,10 @@
-#!perl
+#!parrot
# Copyright (C) 2009, Parrot Foundation.
# $Id$
-use strict;
-use warnings;
-use lib qw( t . lib ../lib ../../lib );
-use Test::More;
-use Parrot::Test tests => 2;
-
=head1 NAME
-t/library/rand.t - rand tests
+t/library/rand.t - Test the Math::Rand PBC
=head1 SYNOPSIS
@@ -18,47 +12,42 @@
=cut
-pir_output_is( << 'CODE', << 'OUTPUT', 'rand / srand' );
-.sub test :main
+.sub main :main
+ .include 'test_more.pir'
+
+ plan(7)
+ test_rand_srand()
+ test_rand_max()
+.end
+
+.sub test_rand_srand
load_bytecode 'Math/Rand.pbc'
.local pmc rand
rand = get_global [ 'Math'; 'Rand' ], 'rand'
.local pmc srand
srand = get_global [ 'Math'; 'Rand' ], 'srand'
$I0 = rand()
- say $I0
+ is($I0,16838)
$I0 = rand()
- say $I0
+ is($I0,5758)
$I0 = rand()
- say $I0
+ is($I0,10113)
$I0 = rand()
- say $I0
+ is($I0,17515)
srand(1)
$I0 = rand()
- say $I0
+ is($I0,16838)
$I0 = rand()
- say $I0
+ is($I0,5758)
.end
-CODE
-16838
-5758
-10113
-17515
-16838
-5758
-OUTPUT
-pir_output_is( << 'CODE', << 'OUTPUT', 'RAND_MAX' );
-.sub test :main
+.sub test_rand_max
load_bytecode 'Math/Rand.pbc'
.local pmc rand_max
rand_max = get_global [ 'Math'; 'Rand' ], 'RAND_MAX'
$I0 = rand_max()
- say $I0
+ is($I0,32767)
.end
-CODE
-32767
-OUTPUT
# Local Variables:
Modified: branches/context_pmc3/t/op/gc.t
==============================================================================
--- branches/context_pmc3/t/op/gc.t Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/t/op/gc.t Thu Aug 27 22:16:16 2009 (r40833)
@@ -23,22 +23,26 @@
=cut
-pasm_output_is( <<'CODE', '1', "sweep 1" );
- interpinfo I1, 2 # How many GC mark runs have we done already?
+pir_output_is( <<'CODE', '1', "sweep 1" );
+.include 'interpinfo.pasm'
+.sub main :main
+ $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS # How many GC mark runs have we done already?
sweep 1
- interpinfo I2, 2 # Should be one more now
- sub I3, I2, I1
- print I3
- end
+ $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be one more now
+ $I3 = $I2 - $I1
+ print $I3
+.end
CODE
-pasm_output_is( <<'CODE', '0', "sweep 0" );
- interpinfo I1, 2 # How many GC mark runs have we done already?
+pir_output_is( <<'CODE', '0', "sweep 0" );
+.include 'interpinfo.pasm'
+.sub main :main
+ $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS # How many GC mark runs have we done already?
sweep 0
- interpinfo I2, 2 # Should be same
- sub I3, I2, I1
- print I3
- end
+ $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be same
+ $I3 = $I2 - $I1
+ print $I3
+.end
CODE
pasm_output_is( <<'CODE', '1', "sweep 0, with object that need destroy" );
@@ -68,13 +72,15 @@
end
CODE
-pasm_output_is( <<'CODE', '1', "collect" );
- interpinfo I1, 3 # How many garbage collections have we done already?
+pir_output_is( <<'CODE', '1', "collect" );
+.include 'interpinfo.pasm'
+.sub main :main
+ $I1 = interpinfo .INTERPINFO_GC_COLLECT_RUNS # How many garbage collections have we done already?
collect
- interpinfo I2, 3 # Should be one more now
- sub I3, I2, I1
- print I3
- end
+ $I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS # Should be one more now
+ $I3 = $I2 - $I1
+ print $I3
+.end
CODE
pasm_output_is( <<'CODE', <<'OUTPUT', "collectoff/on" );
@@ -123,33 +129,33 @@
1
OUTPUT
-pasm_output_is( <<'CODE', <<OUTPUT, "vanishing singleton PMC" );
-_main:
- .const 'Sub' P0 = "_rand"
- new P16, 'Env'
- set P16['Foo'], 'bar'
- set I16, 100
- set I17, 0
-loop:
- sweep 1
- invokecc P0
- inc I17
- lt I17, I16, loop
- print "ok\n"
- end
+pir_output_is( <<'CODE', <<OUTPUT, "vanishing singleton PMC" );
+.sub main :main
+ $P16 = new 'Env'
+ $P16['Foo'] = 'bar'
+ $I16 = 100
+ $I17 = 0
+
+ loop:
+ sweep 1
+ _rand()
+ $I17 += 1
+ if $I17 <= $I16 goto loop
+ say "ok"
+.end
+
+.sub _rand
+ $P16 = new 'Env'
+ $P5 = $P16['Foo']
+ if $P5 != 'bar' goto err
+ .return()
+ err:
+ say "singleton destroyed .Env = ."
+ $P16 = new 'Env'
+ $S16 = typeof $P16
+ say $S16
+.end
-.pcc_sub _rand:
- new P16, 'Env'
- set P5, P16['Foo']
- ne P5, 'bar', err
- returncc
-err:
- print "singleton destroyed .Env = ."
- new P16, 'Env'
- typeof S16, P16
- print S16
- print "\n"
- end
CODE
ok
OUTPUT
Modified: branches/context_pmc3/t/pmc/default.t
==============================================================================
--- branches/context_pmc3/t/pmc/default.t Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/t/pmc/default.t Thu Aug 27 22:16:16 2009 (r40833)
@@ -1,13 +1,7 @@
-#!perl
-# Copyright (C) 2006-2007, Parrot Foundation.
+#!parrot
+# Copyright (C) 2006-2009, Parrot Foundation.
# $Id$
-use strict;
-use warnings;
-use lib qw( . lib ../lib ../../lib );
-use Test::More;
-use Parrot::Test tests => 2;
-
=head1 NAME
t/pmc/default.t - test default PMC
@@ -23,17 +17,20 @@
=cut
-pir_output_is( <<'CODE', <<'OUT', 'new', todo => 'not implemeted' );
-.sub 'test' :main
- new P0, ['default']
- print "ok 1\n"
+.sub main :main
+ .include 'test_more.pir'
+
+ plan(3)
+ test_default()
+ test_inspect_vtable_function()
.end
-CODE
-ok 1
-OUT
-pir_output_is( <<'CODE', <<'OUT', 'inspect vtable function');
-.sub 'test' :main
+.sub test_default
+ #new $P0, ['default']
+ todo(0,'the default PMC does not exist')
+.end
+
+.sub test_inspect_vtable_function
$P0 = new ['String']
$P1 = inspect $P0, 'flags'
$I9 = 1 << 9 # PObj_is_PMC_FLAG
@@ -41,22 +38,11 @@
$I0 = $P1
$I1 = $I0 & $I9
-
- if $I1 goto ok_1
- print "not "
- ok_1:
- print "ok 1\n"
+ ok($I1)
$I1 = $I0 & $I29
- unless $I1 goto ok_2
- print "not "
- ok_2:
- print "ok 2\n"
+ nok($I1)
.end
-CODE
-ok 1
-ok 2
-OUT
# Local Variables:
# mode: cperl
Modified: branches/context_pmc3/t/pmc/parrotinterpreter.t
==============================================================================
--- branches/context_pmc3/t/pmc/parrotinterpreter.t Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/t/pmc/parrotinterpreter.t Thu Aug 27 22:16:16 2009 (r40833)
@@ -1,13 +1,7 @@
-#!perl
-# Copyright (C) 2006-2007, Parrot Foundation.
+#!parrot
+# Copyright (C) 2006-2009, Parrot Foundation.
# $Id$
-use strict;
-use warnings;
-use lib qw( . lib ../lib ../../lib );
-use Test::More;
-use Parrot::Test tests => 2;
-
=head1 NAME
t/pmc/parrotinterpreter.t - test the ParrotInterpreter PMC
@@ -23,19 +17,23 @@
=cut
-pir_output_is( <<'CODE', <<'OUT', 'create new interpreter' );
-.sub 'test' :main
+.sub main :main
+ .include 'test_more.pir'
+
+ plan(3)
+ test_new()
+ test_hll_map()
+.end
+
+.sub test_new
new $P0, ['ParrotInterpreter']
- print "ok 1\n"
+ ok(1,'new')
.end
-CODE
-ok 1
-OUT
-pir_output_is( <<'CODE', <<'OUT', 'setting HLL map dynamically' );
.HLL 'Perl6'
-.sub 'main' :main
+.sub test_hll_map
+ .include 'test_more.pir'
$P0 = get_class 'Integer'
$P1 = subclass $P0, 'MyInt'
@@ -43,18 +41,14 @@
$P2.'hll_map'($P0, $P1)
$P3 = 'foo'()
- say $P3 # "3\n"
+ is($P3,3)
$S0 = typeof $P3
- say $S0 # "MyInt"
+ is($S0,"MyInt")
.end
-.sub 'foo'
+.sub foo
.return (3)
.end
-CODE
-3
-MyInt
-OUT
# Local Variables:
# mode: cperl
Modified: branches/context_pmc3/t/pmc/pmc.t
==============================================================================
--- branches/context_pmc3/t/pmc/pmc.t Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/t/pmc/pmc.t Thu Aug 27 22:16:16 2009 (r40833)
@@ -24,24 +24,26 @@
=cut
-pasm_output_is( <<'CODE', <<'OUTPUT', "newpmc" );
- print "starting\n"
- new P0, ['Integer']
- print "ending\n"
- end
+pir_output_is( <<'CODE', <<'OUTPUT', "newpmc" );
+.sub main
+ say "starting"
+ new $P0, ['Integer']
+ say "ending"
+.end
CODE
starting
ending
OUTPUT
-pasm_output_is( <<'CODE', <<'OUTPUT', 'typeof' );
- new P0, ['Integer']
- typeof S0,P0
- eq S0, "Integer", OK_1
+pir_output_is( <<'CODE', <<'OUTPUT', 'typeof' );
+.sub main
+ new $P0, ['Integer']
+ typeof $S0, $P0
+ eq $S0, "Integer", OK_1
print "not "
OK_1:
print "ok 1\n"
- end
+.end
CODE
ok 1
OUTPUT
@@ -56,203 +58,207 @@
while ( my ( $type, $id ) = each %pmc_types ) {
next
if $types_we_cant_test{$type};
- my $set_ro = ( $type =~ /^Const\w+/ ) ? <<EOPASM : '';
- new P10, ['Integer']
- set P10, 1
- setprop P0, "_ro", P10
-EOPASM
- $checkTypes .= <<"CHECK";
- new P0, '$type'
- $set_ro
- set S1, "$type"
- typeof S0, P0
- ne S0, S1, L_BadName
+ my $set_ro = ( $type =~ /^Const\w+/ ) ? <<'PIR' : '';
+ new $P10, ['Integer']
+ set $P10, 1
+ setprop $P0, "_ro", $P10
+PIR
+ $checkTypes .= qq{ new \$P0, '$type'\n$set_ro\n};
+ $checkTypes .= qq{ set \$S1, "$type"\n};
+ $checkTypes .= <<'CHECK';
+ typeof $S0, $P0
+ ne $S0, $S1, L_BadName
CHECK
}
-pasm_output_like( <<"CODE", <<OUTPUT, "PMC type check" );
- new P10, ['Hash']
- new P11, ['Hash']
+pir_output_like( <<"CODE", qr/All names ok/, "PMC type check" );
+.sub main
+ new \$P10, ['Hash']
+ new \$P11, ['Hash']
$checkTypes
- print "All names ok.\\n"
+ say "All names ok."
end
L_BadName:
- print S1
+ print \$S1
print " PMCs have incorrect name \\""
- print S0
+ print \$S0
print "\\"\\n"
- end
+.end
CODE
-/All names ok/
-OUTPUT
-pasm_error_output_like( <<'CODE', <<'OUTPUT', 'find_method' );
- new P1, ['Integer']
- find_method P0, P1, "no_such_meth"
- end
+pir_error_output_like( <<'CODE', <<'OUTPUT', 'find_method' );
+.sub main
+ new $P1, ['Integer']
+ find_method $P0, $P1, "no_such_meth"
+.end
CODE
/Method 'no_such_meth' not found for invocant of class 'Integer'/
OUTPUT
-pasm_output_is( <<'CODE', <<'OUTPUT', "eq_addr same" );
- new P0, ['Integer']
- set P1, P0
- eq_addr P0, P1, OK1
+pir_output_is( <<'CODE', <<'OUTPUT', "eq_addr same" );
+.sub main
+ new $P0, ['Integer']
+ set $P1, $P0
+ eq_addr $P0, $P1, OK1
print "not "
OK1: print "ok 1\n"
- ne_addr P0, P1, BAD2
+ ne_addr $P0, $P1, BAD2
branch OK2
BAD2: print "not "
OK2: print "ok 2\n"
- end
+.end
CODE
ok 1
ok 2
OUTPUT
-pasm_output_is( <<'CODE', <<'OUTPUT', "eq_addr diff" );
- new P0, ['Integer']
- new P1, ['Integer']
- ne_addr P0, P1, OK1
+pir_output_is( <<'CODE', <<'OUTPUT', "eq_addr diff" );
+.sub main
+ new $P0, ['Integer']
+ new $P1, ['Integer']
+ ne_addr $P0, $P1, OK1
print "not "
OK1: print "ok 1\n"
- eq_addr P0, P1, BAD2
+ eq_addr $P0, $P1, BAD2
branch OK2
BAD2: print "not "
OK2: print "ok 2\n"
- end
+.end
CODE
ok 1
ok 2
OUTPUT
-pasm_output_is( <<'CODE', <<'OUTPUT', "if_null" );
- null P0
- if_null P0, OK1
+pir_output_is( <<'CODE', <<'OUTPUT', "if_null" );
+.sub main
+ null $P0
+ if_null $P0, OK1
print "not "
OK1: print "ok 1\n"
- new P0, ['Integer']
- if_null P0, BAD2
+ new $P0, ['Integer']
+ if_null $P0, BAD2
branch OK2
BAD2: print "not "
OK2: print "ok 2\n"
- end
+.end
CODE
ok 1
ok 2
OUTPUT
-pasm_output_is( <<'CODE', <<'OUTPUT', "Env PMCs are singletons" );
- new P0, ['Env']
- new P1, ['Env']
- eq_addr P0, P1, ok
+pir_output_is( <<'CODE', <<'OUTPUT', "Env PMCs are singletons" );
+.sub main
+ new $P0, ['Env']
+ new $P1, ['Env']
+ eq_addr $P0, $P1, ok
print "not the same "
ok: print "ok\n"
- end
+.end
CODE
ok
OUTPUT
-pasm_output_is( <<'CODE', <<'OUTPUT', "issame" );
- new P0, ['Undef']
- new P1, ['Undef']
- set P1, P0
- issame I0, P0, P1
- print I0
- isntsame I0, P0, P1
- print I0
- new P2, ['Undef']
- issame I0, P0, P2
- print I0
- isntsame I0, P0, P2
- print I0
- print "\n"
- end
+pir_output_is( <<'CODE', <<'OUTPUT', "issame" );
+.sub main
+ new $P0, ['Undef']
+ new $P1, ['Undef']
+ set $P1, $P0
+ issame $I0, $P0, $P1
+ print $I0
+ isntsame $I0, $P0, $P1
+ print $I0
+ new $P2, ['Undef']
+ issame $I0, $P0, $P2
+ print $I0
+ isntsame $I0, $P0, $P2
+ say $I0
+.end
CODE
1001
OUTPUT
-pasm_output_is( <<'CODE', <<'OUT', ".const - Sub constant" );
-.pcc_sub :main main:
+pir_output_is( <<'CODE', <<'OUT', ".const - Sub constant" );
+.sub main
print "ok 1\n"
- .const 'Sub' P0 = "foo"
- invokecc P0
+ .const 'Sub' $P0 = "foo"
+ invokecc $P0
print "ok 3\n"
- end
-.pcc_sub foo:
+.end
+.sub foo
print "ok 2\n"
returncc
+.end
CODE
ok 1
ok 2
ok 3
OUT
-pir_output_is( <<'CODE', <<'OUT', "pmc constant 1" );
+pir_output_is( <<'CODE', <<'OUT', "Integer pmc constant " );
.sub main :main
.const 'Integer' i = "42"
- print i
- print "\n"
+ say i
.end
CODE
42
OUT
-pir_output_is( <<'CODE', <<'OUT', "pmc constant 2" );
+pir_output_is( <<'CODE', <<'OUT', "Float pmc constant " );
.sub main :main
- .const 'Integer' i = "42"
- print i
- print "\n"
+ .const 'Float' j = "4.2"
+ say j
.end
CODE
-42
+4.2
OUT
-pasm_output_is( <<'CODE', <<'OUT', "pmc constant PASM" );
- .const 'Integer' P0 = "42"
- print P0
- print "\n"
- end
+pir_output_is( <<'CODE', <<'OUT', "pmc constant" );
+.sub main
+ .const 'Integer' $P0 = "42"
+ say $P0
+.end
CODE
42
OUT
-pasm_output_is( <<'CODE', <<'OUT', "logical or, and, xor" );
- new P0, ['Integer']
- set P0, 2
- new P1, ['Undef']
- or P2, P0, P1
- eq_addr P2, P0, ok1
+pir_output_is( <<'CODE', <<'OUT', "logical or, and, xor" );
+.sub main
+ new $P0, ['Integer']
+ set $P0, 2
+ new $P1, ['Undef']
+ or $P2, $P0, $P1
+ eq_addr $P2, $P0, ok1
print "not "
ok1:
print "ok 1\n"
- and P2, P0, P1
- eq_addr P2, P1, ok2
+ and $P2, $P0, $P1
+ eq_addr $P2, $P1, ok2
print "not "
ok2:
print "ok 2\n"
- xor P2, P0, P1
- eq_addr P2, P0, ok3
+ xor $P2, $P0, $P1
+ eq_addr $P2, $P0, ok3
print "not "
ok3:
print "ok 3\n"
- end
+.end
CODE
ok 1
ok 2
ok 3
OUT
-pasm_output_is( <<'CODE', <<'OUTPUT', "new_p_s" );
- new P3, ['Integer']
- set P3, "42"
- typeof S0, P3
- print S0
+pir_output_is( <<'CODE', <<'OUTPUT', "new_p_s" );
+.sub main
+ new $P3, ['Integer']
+ set $P3, "42"
+ typeof $S0, $P3
+ print $S0
print "\n"
- set I0, P3
- print I0
+ set $I0, $P3
+ print $I0
print "\n"
- end
+.end
CODE
String
42
Modified: branches/context_pmc3/t/pmc/undef.t
==============================================================================
--- branches/context_pmc3/t/pmc/undef.t Thu Aug 27 22:15:21 2009 (r40832)
+++ branches/context_pmc3/t/pmc/undef.t Thu Aug 27 22:16:16 2009 (r40833)
@@ -19,7 +19,7 @@
.sub main :main
.include 'test_more.pir'
- plan(21)
+ plan(22)
morph_to_string()
undef_pmc_is_false()
@@ -169,19 +169,30 @@
.sub set_undef_to_object
$P0 = new "Undef"
+ $P1 = get_class 'Integer'
$P2 = new 'Integer'
assign $P0, $P2
- ok( 1, 'Assign Integer to Undef' )
+ $I0 = isa $P0, $P1
+ ok( $I0, 'Assign Integer to Undef' )
$P0 = new "Undef"
$P1 = newclass "HI"
$P2 = new $P1
assign $P0, $P2
- ok( 1, 'Assign Object to Undef' )
+ $I0 = isa $P0, $P1
+ ok( $I0, 'Assign Object to Undef' )
+
+ $P0 = new "Undef"
+ $P1 = subclass 'ResizablePMCArray', 'FooRPA'
+ $P2 = new $P1
+ assign $P0, $P2
+ $I0 = isa $P0, $P1
+ ok( $I0, 'Assign Object with PMC parent to Undef' )
# TODO: Needs tests to verify that the values and metadata are preserved
# across the assignment
.end
+
# Local Variables:
# mode: pir
# fill-column: 100
More information about the parrot-commits
mailing list