[svn:parrot] r40952 - in branches/context_pmc3: . compilers/nqp/src compilers/pct/src/POST config/gen/crypto config/gen/platform/netbsd docs docs/book/pct docs/pdds docs/project include/parrot src src/call src/dynpmc src/gc src/interp src/jit/i386 src/ops src/pmc src/runcore t/op t/pmc tools/dev
bacek at svn.parrot.org
bacek at svn.parrot.org
Thu Sep 3 10:17:46 UTC 2009
Author: bacek
Date: Thu Sep 3 10:17:39 2009
New Revision: 40952
URL: https://trac.parrot.org/parrot/changeset/40952
Log:
Last merge from trunk before mergin back.
Conflicts:
MANIFEST
docs/pdds/pdd17_pmc.pod
include/parrot/pmc.h
src/gc/api.c
src/ops/set.ops
src/pmc.c
src/pmc/eventhandler.pmc
src/pmc/exception.pmc
src/pmc/nci.pmc
src/pmc/sub.pmc
t/op/gc.t
Added:
branches/context_pmc3/t/pmc/integer-old.t
branches/context_pmc3/tools/dev/parrot_shell.pl
Modified:
branches/context_pmc3/MANIFEST
branches/context_pmc3/MANIFEST.generated
branches/context_pmc3/compilers/nqp/src/builtins.pir
branches/context_pmc3/compilers/pct/src/POST/Compiler.pir
branches/context_pmc3/config/gen/crypto/digest_pmc.in
branches/context_pmc3/config/gen/platform/netbsd/math.c
branches/context_pmc3/config/gen/platform/netbsd/misc.c
branches/context_pmc3/docs/book/pct/ch03_compiler_tools.pod
branches/context_pmc3/docs/debugger.pod
branches/context_pmc3/docs/embed.pod
branches/context_pmc3/docs/memory_internals.pod
branches/context_pmc3/docs/pdds/pdd09_gc.pod
branches/context_pmc3/docs/pdds/pdd17_pmc.pod
branches/context_pmc3/docs/pdds/pdd28_strings.pod
branches/context_pmc3/docs/pmc.pod
branches/context_pmc3/docs/project/support_policy.pod
branches/context_pmc3/docs/vtables.pod
branches/context_pmc3/include/parrot/extend.h
branches/context_pmc3/include/parrot/pmc.h
branches/context_pmc3/include/parrot/pobj.h
branches/context_pmc3/src/call/pcc.c
branches/context_pmc3/src/dynpmc/gdbmhash.pmc
branches/context_pmc3/src/dynpmc/rational.pmc
branches/context_pmc3/src/gc/api.c
branches/context_pmc3/src/gc/generational_ms.c
branches/context_pmc3/src/gc/system.c
branches/context_pmc3/src/hll.c
branches/context_pmc3/src/interp/inter_cb.c
branches/context_pmc3/src/jit/i386/jit_defs.c
branches/context_pmc3/src/misc.c
branches/context_pmc3/src/oo.c
branches/context_pmc3/src/ops/set.ops
branches/context_pmc3/src/packdump.c
branches/context_pmc3/src/packfile.c
branches/context_pmc3/src/pmc.c
branches/context_pmc3/src/pmc/bigint.pmc
branches/context_pmc3/src/pmc/bignum.pmc
branches/context_pmc3/src/pmc/class.pmc
branches/context_pmc3/src/pmc/eventhandler.pmc
branches/context_pmc3/src/pmc/exception.pmc
branches/context_pmc3/src/pmc/exceptionhandler.pmc
branches/context_pmc3/src/pmc/filehandle.pmc
branches/context_pmc3/src/pmc/fixedbooleanarray.pmc
branches/context_pmc3/src/pmc/fixedfloatarray.pmc
branches/context_pmc3/src/pmc/fixedintegerarray.pmc
branches/context_pmc3/src/pmc/lexinfo.pmc
branches/context_pmc3/src/pmc/managedstruct.pmc
branches/context_pmc3/src/pmc/nci.pmc
branches/context_pmc3/src/pmc/object.pmc
branches/context_pmc3/src/pmc/packfileannotation.pmc
branches/context_pmc3/src/pmc/packfileconstanttable.pmc
branches/context_pmc3/src/pmc/packfilefixuptable.pmc
branches/context_pmc3/src/pmc/packfilerawsegment.pmc
branches/context_pmc3/src/pmc/parrotinterpreter.pmc
branches/context_pmc3/src/pmc/parrotlibrary.pmc
branches/context_pmc3/src/pmc/parrotrunningthread.pmc
branches/context_pmc3/src/pmc/resizablebooleanarray.pmc
branches/context_pmc3/src/pmc/resizableintegerarray.pmc
branches/context_pmc3/src/pmc/scheduler.pmc
branches/context_pmc3/src/pmc/sockaddr.pmc
branches/context_pmc3/src/pmc/string.pmc
branches/context_pmc3/src/pmc/timer.pmc
branches/context_pmc3/src/pmc/undef.pmc
branches/context_pmc3/src/runcore/cores.c
branches/context_pmc3/t/op/box.t
branches/context_pmc3/t/op/gc.t
branches/context_pmc3/t/op/string.t
branches/context_pmc3/t/pmc/integer.t
branches/context_pmc3/t/pmc/packfiledirectory.t
branches/context_pmc3/t/pmc/packfilerawsegment.t
branches/context_pmc3/t/pmc/string.t
branches/context_pmc3/tools/dev/fetch_languages.pl
branches/context_pmc3/tools/dev/pbc_to_exe.pir
Modified: branches/context_pmc3/MANIFEST
==============================================================================
--- branches/context_pmc3/MANIFEST Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/MANIFEST Thu Sep 3 10:17:39 2009 (r40952)
@@ -1,7 +1,7 @@
# ex: set ro:
# $Id$
#
-# generated by tools/dev/mk_manifest_and_skip.pl Tue Sep 1 11:42:14 2009 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Sun Aug 30 20:35:30 2009 UT
#
# See below for documentation on the format of this file.
#
@@ -1873,6 +1873,7 @@
t/pmc/hash.t [test]
t/pmc/hashiterator.t [test]
t/pmc/hashiteratorkey.t [test]
+t/pmc/integer-old.t [test]
t/pmc/integer.t [test]
t/pmc/io.t [test]
t/pmc/io_iterator.t [test]
@@ -2153,6 +2154,7 @@
tools/dev/parrot.supp []
tools/dev/parrot_api.pl []
tools/dev/parrot_coverage.pl []
+tools/dev/parrot_shell.pl []
tools/dev/parrotbench.pl []
tools/dev/pbc_header.pl []
tools/dev/pbc_to_exe.pir [devel]
Modified: branches/context_pmc3/MANIFEST.generated
==============================================================================
--- branches/context_pmc3/MANIFEST.generated Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/MANIFEST.generated Thu Sep 3 10:17:39 2009 (r40952)
@@ -171,10 +171,10 @@
runtime/parrot/library/parrotlib.pbc [main]
runtime/parrot/library/pcore.pbc [main]
runtime/parrot/library/pcre.pbc [main]
-runtime/parrot/library/PCT/Grammar.pbc [pct]
-runtime/parrot/library/PCT/HLLCompiler.pbc [pct]
-runtime/parrot/library/PCT/PAST.pbc [pct]
-runtime/parrot/library/PCT.pbc [pct]
+runtime/parrot/library/PCT/Grammar.pbc [main]
+runtime/parrot/library/PCT/HLLCompiler.pbc [main]
+runtime/parrot/library/PCT/PAST.pbc [main]
+runtime/parrot/library/PCT.pbc [main]
runtime/parrot/library/PGE/Dumper.pbc [main]
runtime/parrot/library/PGE/Glob.pbc [main]
runtime/parrot/library/PGE/Hs.pbc [main]
Modified: branches/context_pmc3/compilers/nqp/src/builtins.pir
==============================================================================
--- branches/context_pmc3/compilers/nqp/src/builtins.pir Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/compilers/nqp/src/builtins.pir Thu Sep 3 10:17:39 2009 (r40952)
@@ -129,6 +129,24 @@
.return ()
.end
+=item C<eval(lang,code)>
+
+=cut
+
+.sub 'eval'
+ .param string text
+ .param string lang
+ .local pmc c, code
+ lang = downcase lang
+ load_language lang
+ c = compreg lang
+ print 'evaling in language: '
+ say lang
+ code = c.'compile'(text)
+ $P0 = code()
+ .return ($P0)
+.end
+
=back
=cut
Modified: branches/context_pmc3/compilers/pct/src/POST/Compiler.pir
==============================================================================
--- branches/context_pmc3/compilers/pct/src/POST/Compiler.pir Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/compilers/pct/src/POST/Compiler.pir Thu Sep 3 10:17:39 2009 (r40952)
@@ -82,6 +82,8 @@
pos = cpost['pos']
if null pos goto done_subline
source = cpost['source']
+ $I0 = can source, 'lineof'
+ unless $I0 goto done_subline
line = source.'lineof'(pos)
inc line
done_subline:
Modified: branches/context_pmc3/config/gen/crypto/digest_pmc.in
==============================================================================
--- branches/context_pmc3/config/gen/crypto/digest_pmc.in Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/config/gen/crypto/digest_pmc.in Thu Sep 3 10:17:39 2009 (r40952)
@@ -22,7 +22,6 @@
pmclass @TEMP_md_name@
dynpmc
- need_ext
group digest_group
lib crypto {
@@ -37,7 +36,7 @@
@TEMP_md_guard@
@TEMP_md_ctx@ *c = mem_allocate_zeroed_typed(@TEMP_md_ctx@);
PMC_data(SELF) = c;
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
#else
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_ILL_INHERIT,
"@TEMP_md_name@ is disabled");
@@ -76,7 +75,7 @@
memcpy(c, PMC_data(SELF), sizeof (@TEMP_md_ctx@));
PMC_data(retval) = c;
- PObj_active_destroy_SET(retval);
+ PObj_custom_destroy_SET(retval);
return retval;
#else
return NULL;
Modified: branches/context_pmc3/config/gen/platform/netbsd/math.c
==============================================================================
--- branches/context_pmc3/config/gen/platform/netbsd/math.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/config/gen/platform/netbsd/math.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -22,14 +22,8 @@
*/
-/*
- * force atan2() to use IEEE behavior
- */
-
#include <math.h>
-_LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
-
#if DOUBLE_SIZE == 2 * INT_SIZE
/*
Modified: branches/context_pmc3/config/gen/platform/netbsd/misc.c
==============================================================================
--- branches/context_pmc3/config/gen/platform/netbsd/misc.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/config/gen/platform/netbsd/misc.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -26,17 +26,23 @@
=item C<void Parrot_platform_init_code(void)>
Initialize Parrot for the NetBSD platform.
-So far only turns off SIGFPE for Alpha.
+So far turns off SIGFPE for Alpha, and
+ensures IEEE floating-point semantics from
+the math library.
=cut
*/
#include <signal.h>
+#include <math.h>
void
Parrot_platform_init_code(void)
{
+
+ _LIB_VERSION = _IEEE_; /* force IEEE math semantics and behaviour */
+
#if defined(__alpha__)
signal(SIGFPE, SIG_IGN);
#endif
Modified: branches/context_pmc3/docs/book/pct/ch03_compiler_tools.pod
==============================================================================
--- branches/context_pmc3/docs/book/pct/ch03_compiler_tools.pod Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/docs/book/pct/ch03_compiler_tools.pod Thu Sep 3 10:17:39 2009 (r40952)
@@ -30,7 +30,7 @@
executing the new Perl 6 language, when specifications for that were first
starting to be drafted. However, as time went on it was decided that Parrot
would benefit from having a clean abstraction layer between it's internals
-and the Perl 6 language syntax. This clean abstraction layer brough with it
+and the Perl 6 language syntax. This clean abstraction layer brought with it
the side effect that Parrot could be used to host a wide variety of dynamic
languages, not just Perl 6. And beyond just hosting them, it could
facilitate their advancement, interaction, and code sharing.
@@ -42,7 +42,7 @@
all those features to any languages that wanted them.
Perl 6, under the project name Rakudo N<http://www.rakudo.org>, is still one
-of the primary user of Parrot and therefore one of the primary drivers in
+of the primary users of Parrot and therefore one of the primary drivers in
its development. However, compilers for other dynamic languages such as
Python 3, Ruby, Tcl, are under active development. Several compilers exist
which are not being as actively developed, and many compilers exist for
Modified: branches/context_pmc3/docs/debugger.pod
==============================================================================
--- branches/context_pmc3/docs/debugger.pod Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/docs/debugger.pod Thu Sep 3 10:17:39 2009 (r40952)
@@ -20,17 +20,16 @@
required to read this document. Some familiarity with debugging principles is
also mandatory beyond this point.
+
=head1 BUILDING parrot_debugger
-The debugger is not built with Parrot, but you should make it with its specific
-target:
+The debugger is built along with Parrot when you run 'make', but if you want to build
+*only* the debugger, then you can run:
make parrot_debugger
-(where C<make> is the same C<make> incarnation you used to build Parrot).
-
-If everything goes well, you should come up with a F<parrot_debugger>
-executable in the same directory as the Parrot program.
+Which will create a new parrot_debugger executable in the same directory as the parrot
+executable.
=head1 THE DEBUGGER SHELL
Modified: branches/context_pmc3/docs/embed.pod
==============================================================================
--- branches/context_pmc3/docs/embed.pod Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/docs/embed.pod Thu Sep 3 10:17:39 2009 (r40952)
@@ -1853,7 +1853,7 @@
=item C<pmc_type>
-=item C<PObj_active_destroy_SET>
+=item C<PObj_custom_destroy_SET>
=item C<PObj_custom_mark_SET>
Modified: branches/context_pmc3/docs/memory_internals.pod
==============================================================================
--- branches/context_pmc3/docs/memory_internals.pod Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/docs/memory_internals.pod Thu Sep 3 10:17:39 2009 (r40952)
@@ -1,4 +1,4 @@
-# Copyright (C) 2001-2004, Parrot Foundation.
+# Copyright (C) 2001-2009, Parrot Foundation.
# $Id$
=head1 NAME
@@ -117,18 +117,16 @@
=head2 General structure of a buffer-like item
struct parrot_object_t {
- UnionVal cache;
unsigned flags;
...
} PObj;
-This does not totally reflect the current implementation, but is the spirit of
-the abstraction of current objects. The C<UnionVal cache> field is a C<union>
-that contains a variety of pointer and data configurations. The flags field
-may contain a series of flags which indicate the type, status, configuration,
-and special requirements of each item. Buffers, C<PMC>s, and C<PObj>s all
-have these basic fields in common, although they also contain a variety of
-other data fields, depending on type.
+The flags field may contain a series of flags which indicate the type, status,
+configuration, and special requirements of each item. C<Buffer>s, C<PMC>s, and
+C<PObj>s all have this basic field in common.
+
+C<PMC>s and C<Buffer>s each have an additional field which contain a pointer
+to a block of data.
=head2 GC-related PObj flags
@@ -279,5 +277,3 @@
=head1 VERSION
0.1.1 June 2008
-
-
Modified: branches/context_pmc3/docs/pdds/pdd09_gc.pod
==============================================================================
--- branches/context_pmc3/docs/pdds/pdd09_gc.pod Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/docs/pdds/pdd09_gc.pod Thu Sep 3 10:17:39 2009 (r40952)
@@ -1,4 +1,4 @@
-# Copyright (C) 2001-2008, Parrot Foundation.
+# Copyright (C) 2001-2009, Parrot Foundation.
# $Id$
=head1 PDD 9: Garbage Collection Subsystem
@@ -560,7 +560,7 @@
=over 4
-=item PObj_active_destroy_FLAG
+=item PObj_custom_destroy_FLAG
The PMC has some sort of active destructor, and will have that destructor
called when the PMC is destroyed. The destructor is typically called from
@@ -620,6 +620,9 @@
=head2 References
+"Uniprocessor Garbage Collection Techniques"
+http://www.cs.rice.edu/~javaplt/311/Readings/wilson92uniprocessor.pdf
+
"A unified theory of garbage collection":
http://portal.acm.org/citation.cfm?id=1028982
Modified: branches/context_pmc3/docs/pdds/pdd17_pmc.pod
==============================================================================
--- branches/context_pmc3/docs/pdds/pdd17_pmc.pod Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/docs/pdds/pdd17_pmc.pod Thu Sep 3 10:17:39 2009 (r40952)
@@ -44,39 +44,13 @@
All PMCs have the form:
struct PMC {
- UnionVal cache;
Parrot_UInt flags;
VTABLE *vtable;
DPOINTER *data;
PMC *_metadata;
- struct _Sync *_synchronize; # [Note: may be deprecated, see STM]
+ struct _Sync *_synchronize; # [Note: may be deprecated, see STM]
PMC *_next_for_GC;
- };
-
-where C<cache> is a C<UnionVal> union:
-
- typedef union UnionVal {
- struct {
- void *_bufstart;
- size_t _buflen;
- } _b;
- struct {
- DPOINTER *_struct_val;
- PMC *_pmc_val;
- } _ptrs;
- struct _i {
- INTVAL _int_val;
- INTVAL _int_val2;
- } _i;
- FLOATVAL _num_val;
- struct parrot_string_t * _string_val;
- } UnionVal;
-
-C<u> holds data associated with the PMC. This can be in the form of an integer
-value, a floating-point value, a string value, or a pointer to other data.
-C<u> may be empty, since the PMC structure also provides a more general data
-pointer, but is useful for PMCs which hold only a single piece of data (e.g.
-C<PerlInts>).
+ }
C<flags> holds a set of flags associated with the PMC; these are documented
in F<include/parrot/pobj.h>, and are generally only used within the Parrot
@@ -90,8 +64,8 @@
C<data> holds a pointer to the core data associated with the PMC. This
may be null.
-C<_metadata> holds internal PMC metadata. The specification for this has not
-yet been finalized.
+C<_metadata> holds internal PMC metadata (properties). See the setprop/getprop
+ops in F<docs/ops/pmc.pod>.
C<_synchronize> is for access synchronization between shared PMCs.
Modified: branches/context_pmc3/docs/pdds/pdd28_strings.pod
==============================================================================
--- branches/context_pmc3/docs/pdds/pdd28_strings.pod Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/docs/pdds/pdd28_strings.pod Thu Sep 3 10:17:39 2009 (r40952)
@@ -257,30 +257,29 @@
Parrot's internal strings (C<STRING>s) have the following structure:
- struct parrot_string_t {
- UnionVal cache;
- Parrot_UInt flags;
- UINTVAL bufused;
- UINTVAL strlen;
- UINTVAL hashval;
- const struct _encoding *encoding;
- const struct _charset *charset;
- const struct _normalization *normalization;
- };
+ struct parrot_string_t {
+ Parrot_UInt flags;
+ void * _bufstart;
+ size_t _buflen;
+ char *strstart;
+ UINTVAL bufused;
+ UINTVAL strlen;
+ UINTVAL hashval;
+ const struct _encoding *encoding;
+ const struct _charset *charset;
+};
The fields are:
=over 4
-=item cache
+=item _bufstart
-A structure that holds the buffer for the string data and the size of the
-buffer in bytes.
+A pointer to the buffer for the string data.
-{{ NOTE: this is currently called "cache" for compatibility with PMC
-structures. As we eliminate the cache from PMCs, we will flatten out this
-union value in the string structure to two members: a string buffer and the
-size of the buffer used. }}
+=item _buflen
+
+The size of the buffer in bytes.
=item flags
@@ -320,13 +319,6 @@
The charset structure specifies the character set (by index number and by
name) and provides functions for transcoding to and from that character set.
-=item normalization
-
-What normalization form the string data is in, one of the four Unicode
-normalization forms or NFG. This structure stores the current normalization
-form, function pointers for composition and decomposition for the current
-normalization form, and a pointer to the grapheme table for NFG.
-
=back
{{DEPRECATION NOTE: the enum C<parrot_string_representation_t> will be removed
Modified: branches/context_pmc3/docs/pmc.pod
==============================================================================
--- branches/context_pmc3/docs/pmc.pod Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/docs/pmc.pod Thu Sep 3 10:17:39 2009 (r40952)
@@ -42,7 +42,7 @@
C<PMC_data> in the PMC's C<init()> and C<init_pmc()> VTABLE functions (if used)
and it must be destroyed in the C<destroy()> VTABLE function. PMCs with ATTRs
also need to indicate that they need active destruction by calling
-C<PObj_active_destroy_SET()> or C<PObj_custom_mark_destroy_SETALL()>.
+C<PObj_custom_destroy_SET()> or C<PObj_custom_mark_destroy_SETALL()>.
If your PMC only needs to store a single pointer, it can use C<PMC_data> directly.
Note that this may make maintaining your PMC difficult, should more data ever
@@ -80,10 +80,10 @@
VTABLE function must call B<Parrot_gc_mark_PObj_alive()> on all B<PObj>s which your PMC
contains.
-=item PObj_active_destroy_FLAG
+=item PObj_custom_destroy_FLAG
If your PMC allocates any memory or opens any resources during its lifetime, it
-must set B<PObj_active_destroy> and implement the B<destroy()> VTABLE function to
+must set B<PObj_custom_destroy> and implement the B<destroy()> VTABLE function to
free those resources.
=item PObj_needs_early_gc_FLAG
Modified: branches/context_pmc3/docs/project/support_policy.pod
==============================================================================
--- branches/context_pmc3/docs/project/support_policy.pod Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/docs/project/support_policy.pod Thu Sep 3 10:17:39 2009 (r40952)
@@ -164,10 +164,27 @@
=item * bytecode changes (opcode or core PMC removals, renames)
-=item * PARROT_API function changes
+=item * C<PARROT_API> function changes
=item * PIR or PASM syntax changes
=item * API changes in the compiler tools
=back
+
+Please note that these features I<do not> require deprecation notices:
+
+=over 4
+
+=item * Parrot functions I<not> marked with C<PARROT_API>
+
+=item * The layout of Parrot's internal data structures
+
+=item * Parrot internals hidden behind a public API
+
+=back
+
+Note that all pointers passed to and returned from functions marked with
+C<PARROT_API> are considered opaque. We do not guarantee backwards
+compatibility between monthly releases for the layout of these pointers;
+dereference them at your own risk.
Modified: branches/context_pmc3/docs/vtables.pod
==============================================================================
--- branches/context_pmc3/docs/vtables.pod Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/docs/vtables.pod Thu Sep 3 10:17:39 2009 (r40952)
@@ -211,7 +211,7 @@
=item C<destroy>
Do any data shut-down and finalization you need to do. To have this method
-called, you must set the C<Pobj_active_destroy_FLAG>.
+called, you must set the C<Pobj_custom_destroy_FLAG>.
=item C<get_integer>
Modified: branches/context_pmc3/include/parrot/extend.h
==============================================================================
--- branches/context_pmc3/include/parrot/extend.h Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/include/parrot/extend.h Thu Sep 3 10:17:39 2009 (r40952)
@@ -35,10 +35,15 @@
pointer, which is on the stack and as good a thing as any to use as
an anchor */
#define PARROT_CALLIN_START(x) void *oldtop = (x)->lo_var_ptr; \
- if (!oldtop) (x)->lo_var_ptr = &oldtop;
+ if (oldtop) {} else (x)->lo_var_ptr = &oldtop
/* Put the stack top back, if what we cached was NULL. Otherwise we
leave it alone and assume it's OK */
-#define PARROT_CALLIN_END(x) if (!oldtop) (x)->lo_var_ptr = NULL;
+#define PARROT_CALLIN_END(x) do {\
+ if (!oldtop) {\
+ PARROT_ASSERT((x)->lo_var_ptr == &oldtop);\
+ (x)->lo_var_ptr = NULL;\
+ }\
+ } while (0)
#else
Modified: branches/context_pmc3/include/parrot/pmc.h
==============================================================================
--- branches/context_pmc3/include/parrot/pmc.h Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/include/parrot/pmc.h Thu Sep 3 10:17:39 2009 (r40952)
@@ -53,10 +53,10 @@
void Parrot_create_mro(PARROT_INTERP, INTVAL type)
__attribute__nonnull__(1);
-PARROT_EXPORT
-void Parrot_pmc_destroy(PARROT_INTERP, ARGIN(PMC *pmc))
+void Parrot_pmc_destroy(PARROT_INTERP, ARGMOD(PMC *pmc))
__attribute__nonnull__(1)
- __attribute__nonnull__(2);
+ __attribute__nonnull__(2)
+ FUNC_MODIFIES(*pmc);
PARROT_EXPORT
INTVAL PMC_is_null(SHIM_INTERP, ARGIN_NULLOK(const PMC *pmc));
Modified: branches/context_pmc3/include/parrot/pobj.h
==============================================================================
--- branches/context_pmc3/include/parrot/pobj.h Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/include/parrot/pobj.h Thu Sep 3 10:17:39 2009 (r40952)
@@ -38,9 +38,8 @@
v v
The actual set-up is more involved because of padding. obj->bufstart must
-be suitably aligned for any UnionVal. (Perhaps it should be a Buffer
-there instead.) The start of the memory region (as returned by malloc()
-is also suitably aligned for any use. If, for example, malloc() returns
+be suitably aligned. The start of the memory region (as returned by malloc())
+is suitably aligned for any use. If, for example, malloc() returns
objects aligned on 8-byte boundaries, and obj->bufstart is also aligned
on 8-byte boundaries, then there should be 4 bytes of padding. It is
handled differently in the two files alloc_resources.c and res_lea.c.
@@ -192,7 +191,7 @@
/* Mark the buffer as needing GC */
PObj_custom_GC_FLAG = POBJ_FLAG(21),
/* Set if the PObj has a destroy method that must be called */
- PObj_active_destroy_FLAG = POBJ_FLAG(22),
+ PObj_custom_destroy_FLAG = POBJ_FLAG(22),
/* For debugging, report when this buffer gets moved around */
PObj_report_FLAG = POBJ_FLAG(23),
@@ -290,7 +289,7 @@
#define PObj_special_CLEAR(flag, o) do { \
PObj_flag_CLEAR(flag, o); \
if ((PObj_get_FLAGS(o) & \
- (PObj_active_destroy_FLAG | \
+ (PObj_custom_destroy_FLAG | \
PObj_custom_mark_FLAG | \
PObj_needs_early_gc_FLAG))) \
gc_flag_SET(is_special_PMC, o); \
@@ -313,9 +312,17 @@
#define PObj_custom_mark_CLEAR(o) PObj_special_CLEAR(custom_mark, o)
#define PObj_custom_mark_TEST(o) PObj_flag_TEST(custom_mark, o)
-#define PObj_active_destroy_SET(o) PObj_flag_SET(active_destroy, o)
-#define PObj_active_destroy_TEST(o) PObj_flag_TEST(active_destroy, o)
-#define PObj_active_destroy_CLEAR(o) PObj_flag_CLEAR(active_destroy, o)
+#define PObj_custom_destroy_SET(o) PObj_flag_SET(custom_destroy, o)
+#define PObj_custom_destroy_TEST(o) PObj_flag_TEST(custom_destroy, o)
+#define PObj_custom_destroy_CLEAR(o) PObj_flag_CLEAR(custom_destroy, o)
+
+/*******************************************************
+ * DEPRECATED -- use PObj_custom_destroy_FOO() instead *
+ *******************************************************/
+#define PObj_active_destroy_FLAG PObj_custom_destroy_FLAG
+#define PObj_active_destroy_SET(o) PObj_flag_SET(custom_destroy, o)
+#define PObj_active_destroy_TEST(o) PObj_flag_TEST(custom_destroy, o)
+#define PObj_active_destroy_CLEAR(o) PObj_flag_CLEAR(custom_destroy, o)
#define PObj_is_class_SET(o) PObj_flag_SET(is_class, o)
#define PObj_is_class_TEST(o) PObj_flag_TEST(is_class, o)
@@ -357,7 +364,7 @@
#define PObj_custom_mark_destroy_SETALL(o) do { \
PObj_custom_mark_SET(o); \
- PObj_active_destroy_SET(o); \
+ PObj_custom_destroy_SET(o); \
} while (0)
#endif /* PARROT_POBJ_H_GUARD */
Modified: branches/context_pmc3/src/call/pcc.c
==============================================================================
--- branches/context_pmc3/src/call/pcc.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/call/pcc.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -1891,6 +1891,8 @@
Parrot_pcc_set_results_signature(interp, dest_ctx, NULL);
}
+ memset(&st, 0, sizeof st);
+
Parrot_init_arg_indexes_and_sig_pmc(interp, src_ctx, src_indexes,
src_signature, &st.src);
@@ -2953,8 +2955,8 @@
INTVAL n_regs_used[] = { 0, 0, 0, 0, 0, 0, 0, 0 };
/* Each of these is 8K. Do we want 16K on the stack? */
- opcode_t arg_indexes[PCC_ARG_MAX];
- opcode_t result_indexes[PCC_ARG_MAX];
+ opcode_t arg_indexes[PCC_ARG_MAX] = {0};
+ opcode_t result_indexes[PCC_ARG_MAX] = {0};
/* create the signature string, and the various PMCs that are needed to
store all the parameters and parameter counts. */
Modified: branches/context_pmc3/src/dynpmc/gdbmhash.pmc
==============================================================================
--- branches/context_pmc3/src/dynpmc/gdbmhash.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/dynpmc/gdbmhash.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -105,7 +105,7 @@
attrs->db_handle = mem_allocate_zeroed_typed(GDBM_FH);
PMC_data(SELF) = attrs;
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
VTABLE void destroy() {
@@ -214,13 +214,16 @@
if (!dbf) return;
keystr = make_hash_key(interp, key);
- key_gdbm.dsize = keystr->strlen;
- key_gdbm.dptr = keystr->strstart;
- val_gdbm.dsize = value->strlen;
- val_gdbm.dptr = value->strstart;
+ key_gdbm.dptr = Parrot_str_to_cstring(interp, keystr);
+ key_gdbm.dsize = strlen(key_gdbm.dptr);
+ val_gdbm.dptr = Parrot_str_to_cstring(interp, value);
+ val_gdbm.dsize = strlen(val_gdbm.dptr);
gdbm_store(dbf, key_gdbm, val_gdbm, GDBM_REPLACE);
+ Parrot_str_free_cstring(key_gdbm.dptr);
+ Parrot_str_free_cstring(val_gdbm.dptr);
+
return;
}
Modified: branches/context_pmc3/src/dynpmc/rational.pmc
==============================================================================
--- branches/context_pmc3/src/dynpmc/rational.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/dynpmc/rational.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -269,7 +269,7 @@
PMC_data(SELF) = attrs;
PMC_rational(SELF) = (RATIONAL *)malloc(sizeof (RATIONAL));
mpq_init(RT(SELF));
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
#endif
}
Modified: branches/context_pmc3/src/gc/api.c
==============================================================================
--- branches/context_pmc3/src/gc/api.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/gc/api.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -361,20 +361,7 @@
Small_Object_Pool * const pool = (PObj_constant_TEST(pmc)) ?
interp->arena_base->constant_pmc_pool : interp->arena_base->pmc_pool;
- if (PObj_active_destroy_TEST(pmc))
- VTABLE_destroy(interp, pmc);
-
- Parrot_gc_free_pmc_sync(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
- }
- PARROT_ASSERT(NULL == PMC_data(pmc));
-
+ Parrot_pmc_destroy(interp, pmc);
PObj_flags_SETTO((PObj *)pmc, PObj_on_free_list_FLAG);
pool->add_free_object(interp, pool, (PObj *)pmc);
@@ -419,10 +406,13 @@
Parrot_gc_add_pmc_sync(PARROT_INTERP, ARGMOD(PMC *pmc))
{
ASSERT_ARGS(Parrot_gc_add_pmc_sync)
+
+ /* This mutex already exists, leave it alone. */
if (PMC_sync(pmc))
- /* This mutex already exists, leave it alone. */
return;
+
PMC_sync(pmc) = mem_allocate_typed(Sync);
+
if (!PMC_sync(pmc))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_ALLOCATION_ERROR,
"Parrot VM: PMC Sync allocation failed!\n");
@@ -1692,7 +1682,7 @@
=head1 SEE ALSO
-F<include/parrot/gc_api.h>, F<src/cpu_dep.c> and F<docs/pdds/pdd09_gc.pod>.
+F<include/parrot/gc_api.h>, F<src/gc/system.c> and F<docs/pdds/pdd09_gc.pod>.
=head1 HISTORY
Modified: branches/context_pmc3/src/gc/generational_ms.c
==============================================================================
--- branches/context_pmc3/src/gc/generational_ms.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/gc/generational_ms.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -606,7 +606,7 @@
=item C<static void gc_gms_chain_objects(PARROT_INTERP, Small_Object_Pool *pool,
Small_Object_Arena *new_arena, size_t real_size)>
-TODO: interfere active_destroy and put these items into a
+TODO: interfere custom_destroy and put these items into a
separate white area, so that a sweep has just to run through these
objects
@@ -1691,7 +1691,7 @@
PMC * const obj = (PMC*)GMSH_to_PObj(h);
if (PObj_needs_early_gc_TEST(obj))
--arena_base->num_early_gc_PMCs;
- if (PObj_active_destroy_TEST(obj))
+ if (PObj_custom_destroy_TEST(obj))
VTABLE_destroy(interp, (PMC *)obj);
}
pool->free_list = pool->white;
Modified: branches/context_pmc3/src/gc/system.c
==============================================================================
--- branches/context_pmc3/src/gc/system.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/gc/system.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -238,6 +238,7 @@
the "bottom" of the stack. We must trace the entire area between the
top and bottom. */
const size_t lo_var_ptr = (size_t)interp->lo_var_ptr;
+ PARROT_ASSERT(lo_var_ptr);
trace_mem_block(interp, (size_t)lo_var_ptr,
(size_t)&lo_var_ptr);
Modified: branches/context_pmc3/src/hll.c
==============================================================================
--- branches/context_pmc3/src/hll.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/hll.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -53,7 +53,7 @@
#define END_READ_HLL_INFO(interp, hll_info)
#define START_WRITE_HLL_INFO(interp, hll_info) \
do { \
- if (PMC_sync((interp)->HLL_info)) { \
+ if (PObj_is_PMC_shared_TEST(hll_info) && PMC_sync((interp)->HLL_info)) { \
(hll_info) = (interp)->HLL_info = \
Parrot_clone((interp), (interp)->HLL_info); \
if (PMC_sync((interp)->HLL_info)) \
@@ -362,8 +362,8 @@
"no such HLL ID (%vd)", hll_id);
/* the type might already be registered in a non-conflicting way, in which
- * case we can avoid copying */
- if (PMC_sync(hll_info)) {
+ * ca se we can avoid copying */
+ if (PObj_is_PMC_shared_TEST(hll_info) && PMC_sync(hll_info)) {
if (hll_type == Parrot_get_HLL_type(interp, hll_id, core_type))
return;
}
Modified: branches/context_pmc3/src/interp/inter_cb.c
==============================================================================
--- branches/context_pmc3/src/interp/inter_cb.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/interp/inter_cb.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -79,6 +79,7 @@
int type;
char * sig_str;
STRING *sc;
+ char * const signature = Parrot_str_to_cstring(interp, cb_signature);
/*
* we stuff all the information into the user_data PMC and pass that
* on to the external sub
@@ -92,11 +93,13 @@
sc = CONST_STRING(interp, "_sub");
VTABLE_setprop(interp, user_data, sc, sub);
/* only ASCII signatures are supported */
- sig_str = cb_signature->strstart;
+ sig_str = signature;
- if (strlen(sig_str) != 3)
+ if (strlen(sig_str) != 3) {
+ mem_sys_free(signature);
Parrot_ex_throw_from_c_args(interp, NULL, 1,
- "unhandled signature '%s' in make_cb", cb_signature->strstart);
+ "unhandled signature '%Ss' in make_cb", cb_signature);
+ }
++sig_str; /* Skip callback return type */
@@ -109,11 +112,13 @@
type = 'C';
}
else {
+ mem_sys_free(signature);
Parrot_ex_throw_from_c_args(interp, NULL, 1,
- "unhandled signature '%s' in make_cb", cb_signature->strstart);
+ "unhandled signature '%Ss' in make_cb", cb_signature);
}
}
+ mem_sys_free(signature);
cb_sig = pmc_new(interp, enum_class_String);
VTABLE_set_string_native(interp, cb_sig, cb_signature);
sc = CONST_STRING(interp, "_signature");
Modified: branches/context_pmc3/src/jit/i386/jit_defs.c
==============================================================================
--- branches/context_pmc3/src/jit/i386/jit_defs.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/jit/i386/jit_defs.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -2410,7 +2410,7 @@
emitm_ret(pc);
PARROT_ASSERT(pc - jit_info.arena.start <= JIT_ALLOC_SIZE);
/* could shrink arena.start here to used size */
- PObj_active_destroy_SET(pmc_nci);
+ PObj_custom_destroy_SET(pmc_nci);
if (sizeptr)
*sizeptr = JIT_ALLOC_SIZE;
return (void *)D2FPTR(jit_info.arena.start);
Modified: branches/context_pmc3/src/misc.c
==============================================================================
--- branches/context_pmc3/src/misc.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/misc.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -112,6 +112,8 @@
size_t len, ARGIN(const char *pat), va_list args)
{
ASSERT_ARGS(Parrot_vsnprintf)
+ char *str_ret;
+ size_t str_len;
if (len == 0)
return;
len--;
@@ -119,12 +121,15 @@
const STRING * const ret = Parrot_vsprintf_c(interp, pat, args);
/* string_transcode(interp, ret, NULL, NULL, &ret); */
- if (len > ret->bufused) {
- len = ret->bufused;
+ str_ret = Parrot_str_to_cstring(interp, ret);
+ str_len = strlen(str_ret);
+ if (len > str_len) {
+ len = str_len;
}
if (len)
- memcpy(targ, ret->strstart, len);
+ memcpy(targ, str_ret, len);
+ Parrot_str_free_cstring(str_ret);
}
targ[len] = 0;
}
Modified: branches/context_pmc3/src/oo.c
==============================================================================
--- branches/context_pmc3/src/oo.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/oo.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -286,14 +286,13 @@
/* Set custom GC mark and destroy on the object. */
PObj_custom_mark_SET(cloned);
- PObj_active_destroy_SET(cloned);
+ PObj_custom_destroy_SET(cloned);
/* 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 Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/ops/set.ops Thu Sep 3 10:17:39 2009 (r40952)
@@ -25,7 +25,10 @@
=cut
inline op clone(out STR, in STR) :base_mem {
- $1 = Parrot_str_copy(interp, $2);
+ /* cloning a NULL STRING produces an empty STRING; TT #964 */
+ $1 = $2
+ ? Parrot_str_copy(interp, $2)
+ : Parrot_str_new(interp, NULL, 0);
}
@@ -508,10 +511,10 @@
/* 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_data(clone) = NULL;
+ PMC_sync(clone) = NULL;
+ PMC_metadata(clone) = NULL;
PMC_next_for_GC(clone) = NULL;
- PMC_sync(clone) = NULL;
/* Restore metadata. */
if (!PMC_IS_NULL(meta)) {
Modified: branches/context_pmc3/src/packdump.c
==============================================================================
--- branches/context_pmc3/src/packdump.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/packdump.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -111,7 +111,7 @@
"on_free_list",
"custom_mark",
"custom_GC",
- "active_destroy",
+ "custom_destroy",
"report",
"data_is_PMC_array",
"need_finalize",
Modified: branches/context_pmc3/src/packfile.c
==============================================================================
--- branches/context_pmc3/src/packfile.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/packfile.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -26,6 +26,7 @@
#include "parrot/parrot.h"
#include "parrot/embed.h"
+#include "parrot/extend.h"
#include "parrot/packfile.h"
#include "jit.h"
#include "../compilers/imcc/imc.h"
@@ -4922,7 +4923,9 @@
PackFile_fixup_subs(PARROT_INTERP, pbc_action_enum_t what, ARGIN_NULLOK(PMC *eval))
{
ASSERT_ARGS(PackFile_fixup_subs)
+ PARROT_CALLIN_START(interp);
do_sub_pragmas(interp, interp->code, what, eval);
+ PARROT_CALLIN_END(interp);
}
Modified: branches/context_pmc3/src/pmc.c
==============================================================================
--- branches/context_pmc3/src/pmc.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -105,16 +105,21 @@
PARROT_EXPORT
void
-Parrot_pmc_destroy(PARROT_INTERP, ARGIN(PMC *pmc))
+Parrot_pmc_destroy(PARROT_INTERP, ARGMOD(PMC *pmc))
{
ASSERT_ARGS(Parrot_pmc_destroy)
- if (PObj_active_destroy_TEST(pmc)) {
+ if (PObj_custom_destroy_TEST(pmc)) {
VTABLE_destroy(interp, pmc);
/* Prevent repeated calls. */
- PObj_active_destroy_CLEAR(pmc);
+ PObj_custom_destroy_CLEAR(pmc);
}
+ PObj_custom_mark_CLEAR(pmc);
+ PObj_live_CLEAR(pmc);
+
+ Parrot_gc_free_pmc_sync(interp, pmc);
+
if (pmc->vtable->attr_size) {
if (PMC_data(pmc)) {
#if GC_USE_FIXED_SIZE_ALLOCATOR
Modified: branches/context_pmc3/src/pmc/bigint.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/bigint.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/bigint.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -627,7 +627,7 @@
VTABLE void init() {
bigint_init(INTERP, SELF);
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
VTABLE PMC *clone() {
Modified: branches/context_pmc3/src/pmc/bignum.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/bignum.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/bignum.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -841,7 +841,7 @@
VTABLE void init() {
bignum_init(INTERP, SELF);
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
VTABLE PMC *clone() {
Modified: branches/context_pmc3/src/pmc/class.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/class.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/class.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -1222,7 +1222,7 @@
/* Set custom GC mark and destroy on the object. */
PObj_custom_mark_SET(object);
- PObj_active_destroy_SET(object);
+ PObj_custom_destroy_SET(object);
/* Flag that it is an object */
PObj_is_object_SET(object);
Modified: branches/context_pmc3/src/pmc/eventhandler.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/eventhandler.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/eventhandler.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -39,7 +39,7 @@
VTABLE void init() {
PObj_custom_mark_SET(SELF);
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
/*
@@ -101,7 +101,7 @@
INTERP->iglobals, IGLOBALS_INTERPRETER);
PObj_custom_mark_SET(SELF);
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
e->type = type;
e->code = code;
Modified: branches/context_pmc3/src/pmc/exception.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/exception.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/exception.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -84,7 +84,7 @@
VTABLE void init() {
/* Set flags for custom GC mark and destroy. */
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
PObj_custom_mark_SET(SELF);
SET_ATTR_severity(INTERP, SELF, EXCEPT_error);
@@ -124,7 +124,7 @@
}
/* Set flags for custom GC mark. */
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
PObj_custom_mark_SET(SELF);
/* Set up the core struct and default values for the exception object. */
Modified: branches/context_pmc3/src/pmc/exceptionhandler.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/exceptionhandler.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/exceptionhandler.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -56,7 +56,7 @@
* context - the stacks can only be deeper in the interpreter - so no
* mark of context is needed */
PObj_custom_mark_SET(SELF);
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
/*
Modified: branches/context_pmc3/src/pmc/filehandle.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/filehandle.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/filehandle.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -84,7 +84,7 @@
data_struct->os_handle = (PIOHANDLE) PIO_INVALID_HANDLE;
PObj_custom_mark_SET(SELF);
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
/*
Modified: branches/context_pmc3/src/pmc/fixedbooleanarray.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/fixedbooleanarray.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/fixedbooleanarray.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -45,7 +45,7 @@
*/
VTABLE void init() {
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
/*
@@ -97,7 +97,7 @@
SET_ATTR_bit_array(INTERP, dest, clone_bit_array);
}
- PObj_active_destroy_SET(dest);
+ PObj_custom_destroy_SET(dest);
return dest;
}
@@ -550,15 +550,15 @@
if (info->extra_flags == EXTRA_IS_NULL) {
unsigned char * bit_array;
+ UINTVAL threshold;
const INTVAL size = VTABLE_shift_integer(INTERP, io);
STRING * const s = VTABLE_shift_string(INTERP, io);
- bit_array = (unsigned char*)mem_sys_allocate_zeroed(s->bufused);
- mem_sys_memcopy(bit_array, s->strstart, s->bufused);
+ bit_array = (unsigned char *)Parrot_str_to_cstring(INTERP, s);
+ threshold = Parrot_str_byte_length(interp, s) * BITS_PER_CHAR;
SET_ATTR_size(INTERP, SELF, size);
- SET_ATTR_resize_threshold(INTERP, SELF,
- s->bufused * BITS_PER_CHAR);
+ SET_ATTR_resize_threshold(INTERP, SELF, threshold);
SET_ATTR_bit_array(INTERP, SELF, bit_array);
}
}
Modified: branches/context_pmc3/src/pmc/fixedfloatarray.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/fixedfloatarray.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/fixedfloatarray.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -73,7 +73,7 @@
dest_float_array = (FLOATVAL*)mem_sys_allocate(mem_size);
mem_sys_memcopy(dest_float_array, self_float_array, mem_size);
SET_ATTR_float_array(INTERP, dest, dest_float_array);
- PObj_active_destroy_SET(dest);
+ PObj_custom_destroy_SET(dest);
return dest;
}
@@ -290,7 +290,7 @@
SET_ATTR_size(INTERP, SELF, new_size);
SET_ATTR_float_array(INTERP, SELF,
mem_allocate_n_typed(new_size, FLOATVAL));
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
/*
Modified: branches/context_pmc3/src/pmc/fixedintegerarray.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/fixedintegerarray.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/fixedintegerarray.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -40,7 +40,7 @@
*/
VTABLE void init() {
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
/*
@@ -190,7 +190,7 @@
SET_ATTR_int_array(INTERP, dest, dest_int_array);
mem_sys_memcopy(dest_int_array, int_array, size * sizeof (INTVAL));
- PObj_active_destroy_SET(dest);
+ PObj_custom_destroy_SET(dest);
}
return dest;
@@ -432,7 +432,7 @@
GET_ATTR_int_array(INTERP, SELF, int_array);
SET_ATTR_int_array(INTERP, SELF,
mem_realloc_n_typed(int_array, size, INTVAL));
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
/*
@@ -636,11 +636,7 @@
}
VTABLE void thaw(visit_info *info) {
-
- Parrot_FixedIntegerArray_attributes *attrs =
- mem_allocate_zeroed_typed(Parrot_FixedIntegerArray_attributes);
- PMC_data(SELF) = attrs;
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
if (info->extra_flags == EXTRA_IS_NULL) {
IMAGE_IO * const io = info->image_io;
Modified: branches/context_pmc3/src/pmc/lexinfo.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/lexinfo.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/lexinfo.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -71,7 +71,7 @@
(hash_hash_key_fn)Parrot_str_to_hashval); /* hash */
SELF.set_pointer(hash);
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
/*
Modified: branches/context_pmc3/src/pmc/managedstruct.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/managedstruct.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/managedstruct.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -46,7 +46,7 @@
*/
VTABLE void init() {
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
/*
Modified: branches/context_pmc3/src/pmc/nci.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/nci.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/nci.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -255,7 +255,6 @@
void *orig_func;
PMC * const ret = pmc_new(INTERP, SELF->vtable->base_type);
- PMC_data(ret) = mem_allocate_zeroed_typed(Parrot_NCI_attributes);
nci_info_ret = PARROT_NCI(ret);
/* FIXME if data is malloced (JIT/i386!) then we need
@@ -302,6 +301,7 @@
VTABLE opcode_t *invoke(void *next) {
Parrot_NCI_attributes * const nci_info = PARROT_NCI(SELF);
nci_sub_t func;
+ char *sig_str;
void *orig_func;
PMC *cont;
@@ -324,7 +324,9 @@
nci_jit_sub_t jit_func = (nci_jit_sub_t) D2FPTR(nci_info->func);
/* Parrot_eprintf(interp, "JITTED %S\n", nci_info->signature); */
- jit_func(INTERP, SELF, (char *) nci_info->pcc_params_signature->strstart);
+ sig_str = Parrot_str_to_cstring(interp, nci_info->pcc_params_signature);
+ jit_func(INTERP, SELF, sig_str);
+ Parrot_str_free_cstring(sig_str);
}
else {
if (PObj_flag_TEST(private2, SELF)) {
Modified: branches/context_pmc3/src/pmc/object.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/object.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/object.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -695,10 +695,6 @@
if (info->extra_flags == EXTRA_IS_PROP_HASH) {
SUPER(info);
}
- else if (info->extra_flags == EXTRA_IS_NULL) {
- /* Allocate the object's core data struct */
- PMC_data(SELF) = mem_allocate_zeroed_typed(Parrot_Object_attributes);
- }
}
/*
@@ -714,7 +710,7 @@
VTABLE void thawfinish(visit_info *info) {
/* Set custom GC mark and destroy on the object. */
PObj_custom_mark_SET(SELF);
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
/* Flag that it is an object */
PObj_is_object_SET(SELF);
Modified: branches/context_pmc3/src/pmc/packfileannotation.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/packfileannotation.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/packfileannotation.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -42,7 +42,7 @@
Parrot_PackfileAnnotation_attributes * attrs =
mem_allocate_zeroed_typed(Parrot_PackfileAnnotation_attributes);
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
PMC_data(SELF) = attrs;
}
Modified: branches/context_pmc3/src/pmc/packfileconstanttable.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/packfileconstanttable.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/packfileconstanttable.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -395,6 +395,20 @@
return i;
}
+/*
+
+=item C<METHOD type()>
+
+Set segment type.
+
+=cut
+
+*/
+
+ METHOD type() {
+ RETURN(INTVAL PF_CONST_SEG);
+ }
+
}
/*
Modified: branches/context_pmc3/src/pmc/packfilefixuptable.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/packfilefixuptable.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/packfilefixuptable.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -198,6 +198,20 @@
}
+/*
+
+=item C<METHOD type()>
+
+Set segment type.
+
+=cut
+
+*/
+
+ METHOD type() {
+ RETURN(INTVAL PF_FIXUP_SEG);
+ }
+
}
/*
Modified: branches/context_pmc3/src/pmc/packfilerawsegment.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/packfilerawsegment.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/packfilerawsegment.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -25,6 +25,8 @@
*/
pmclass PackfileRawSegment extends PackfileSegment {
+ /* Type of segment */
+ ATTR INTVAL type;
/* ResizableIntegerArray of opcodes */
ATTR PMC *opcodes;
@@ -43,6 +45,7 @@
mem_allocate_zeroed_typed(Parrot_PackfileRawSegment_attributes);
attrs->opcodes = pmc_new(interp, enum_class_ResizableIntegerArray);
+ attrs->type = PF_BYTEC_SEG;
PObj_custom_mark_destroy_SETALL(SELF);
PMC_data(SELF) = attrs;
@@ -103,9 +106,14 @@
VTABLE void set_pointer(void * pointer) {
const PackFile_Segment * const pfseg =
(const PackFile_Segment *)pointer;
- PMC * opcodes = PARROT_PACKFILERAWSEGMENT(SELF)->opcodes;
+ Parrot_PackfileRawSegment_attributes * attrs =
+ PARROT_PACKFILERAWSEGMENT(SELF);
+ PMC * opcodes = attrs->opcodes;
size_t i;
+ /* Preserve type of unpacked segment */
+ attrs->type = pfseg->type;
+
if (pfseg->size) {
/* copy data to own array */
VTABLE_set_integer_native(interp, opcodes, pfseg->size);
@@ -132,7 +140,7 @@
PMC * opcodes = attrs->opcodes;
size_t i;
- pfseg->type = PF_BYTEC_SEG;
+ pfseg->type = attrs->type;
pfseg->size = VTABLE_get_integer(interp, opcodes);
pfseg->data = mem_allocate_n_typed(pfseg->size, opcode_t);
@@ -187,6 +195,30 @@
PARROT_PACKFILERAWSEGMENT(SELF)->opcodes, key, value);
}
+/*
+
+=item C<METHOD type()>
+
+Set of get segment type.
+
+=cut
+
+TODO: Don't allow create Directory, Annotations, etc segments.
+
+*/
+
+ METHOD type(INTVAL type :optional, INTVAL got_type :opt_flag) {
+ Parrot_PackfileRawSegment_attributes * attrs =
+ PARROT_PACKFILERAWSEGMENT(SELF);
+ INTVAL res;
+
+ if (got_type) {
+ attrs->type = type;
+ }
+
+ res = attrs->type;
+ RETURN(INTVAL res);
+ }
}
/*
Modified: branches/context_pmc3/src/pmc/parrotinterpreter.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/parrotinterpreter.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/parrotinterpreter.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -242,7 +242,7 @@
if (!PMC_interp(SELF)) {
create_interp(SELF, INTERP);
}
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
/*
@@ -268,7 +268,7 @@
if (!PMC_interp(SELF)) {
create_interp(SELF, p);
}
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
@@ -309,7 +309,7 @@
Parrot_ParrotInterpreter_attributes *attrs =
mem_allocate_zeroed_typed(Parrot_ParrotInterpreter_attributes);
PMC_data(SELF) = attrs;
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
PMC_interp(SELF) = (struct parrot_interp_t *)value;
}
@@ -721,7 +721,7 @@
Parrot_ParrotInterpreter_attributes *attrs =
mem_allocate_zeroed_typed(Parrot_ParrotInterpreter_attributes);
PMC_data(SELF) = attrs;
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
PMC_interp(SELF) = INTERP;
Modified: branches/context_pmc3/src/pmc/parrotlibrary.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/parrotlibrary.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/parrotlibrary.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -46,7 +46,7 @@
*/
VTABLE void init() {
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
/*
Modified: branches/context_pmc3/src/pmc/parrotrunningthread.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/parrotrunningthread.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/parrotrunningthread.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -50,7 +50,7 @@
mem_allocate_zeroed_typed(Parrot_ParrotRunningThread_attributes);
attrs->tid = -1;
PMC_data(SELF) = attrs;
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
/*
Modified: branches/context_pmc3/src/pmc/resizablebooleanarray.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/resizablebooleanarray.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/resizablebooleanarray.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -392,7 +392,7 @@
SET_ATTR_bit_array(INTERP, dest, dest_bit_array);
- PObj_active_destroy_SET(dest);
+ PObj_custom_destroy_SET(dest);
return dest;
}
@@ -453,11 +453,7 @@
const UINTVAL tail_pos = VTABLE_shift_integer(INTERP, io);
STRING * const s = VTABLE_shift_string(INTERP, io);
- bit_array = (unsigned char *)mem_sys_allocate_zeroed(s->bufused);
- mem_sys_memcopy(bit_array, (unsigned char *)s->strstart, s->bufused);
- PMC_data(SELF) =
- mem_allocate_zeroed_typed(Parrot_ResizableBooleanArray_attributes);
-
+ bit_array = (unsigned char*)Parrot_str_to_cstring(INTERP, s);
SET_ATTR_size(INTERP, SELF, tail_pos);
SET_ATTR_resize_threshold(INTERP, SELF, head_pos);
SET_ATTR_bit_array(INTERP, SELF, bit_array);
Modified: branches/context_pmc3/src/pmc/resizableintegerarray.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/resizableintegerarray.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/resizableintegerarray.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -294,11 +294,6 @@
}
VTABLE void thaw(visit_info *info) {
-
- Parrot_ResizableIntegerArray_attributes *attrs =
- mem_allocate_zeroed_typed(Parrot_ResizableIntegerArray_attributes);
- PMC_data(SELF) = attrs;
-
if (info->extra_flags == EXTRA_IS_NULL) {
IMAGE_IO * const io = info->image_io;
const INTVAL n = VTABLE_shift_integer(INTERP, io);
Modified: branches/context_pmc3/src/pmc/scheduler.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/scheduler.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/scheduler.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -52,7 +52,7 @@
/* Set flags for custom GC mark and destroy. */
PObj_custom_mark_SET(SELF);
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
/* Set up the core struct. */
core_struct->id = 0;
Modified: branches/context_pmc3/src/pmc/sockaddr.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/sockaddr.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/sockaddr.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -47,7 +47,7 @@
(Parrot_Sockaddr_attributes *) PMC_data(SELF);
pdata_struct->pointer = mem_allocate_zeroed_typed(struct sockaddr_in);
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
}
/*
Modified: branches/context_pmc3/src/pmc/string.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/string.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/string.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -220,11 +220,16 @@
*/
VTABLE void set_string_native(STRING *value) {
+ /* in lieu of a STRINGNULL, promote any NULL STRINGs to empty ones */
+ if (!value)
+ value = Parrot_str_new(INTERP, NULL, 0);
+
/* Only allow constant PMCs to embed constant strings */
if (PObj_constant_TEST(SELF) && !PObj_constant_TEST(value)) {
char *copy = Parrot_str_to_cstring(INTERP, value);
value = Parrot_str_new_init(INTERP, copy, strlen(copy),
- PARROT_DEFAULT_ENCODING, PARROT_DEFAULT_CHARSET, PObj_constant_FLAG);
+ PARROT_DEFAULT_ENCODING, PARROT_DEFAULT_CHARSET,
+ PObj_constant_FLAG);
Parrot_str_free_cstring(copy);
}
@@ -645,6 +650,16 @@
return string_ord(INTERP, s, pos);
}
+ VTABLE PMC *get_pmc_keyed(PMC *key) {
+ return SELF.get_pmc_keyed_int(VTABLE_get_integer(INTERP, key));
+ }
+
+ VTABLE PMC *get_pmc_keyed_int(INTVAL pos) {
+ PMC * const dest = pmc_new(INTERP, SELF->vtable->base_type);
+ VTABLE_set_string_native(INTERP, dest, SELF.get_string_keyed_int(pos));
+ return dest;
+ }
+
VTABLE void set_string_keyed(PMC *key, STRING * const value) {
SELF.set_string_keyed_int(VTABLE_get_integer(INTERP, key), value);
}
@@ -666,6 +681,14 @@
Parrot_str_replace(INTERP, s, pos, 1, c, NULL);
VTABLE_set_string_native(INTERP, SELF, s);
}
+
+ VTABLE void set_pmc_keyed(PMC *key, PMC *value) {
+ SELF.set_pmc_keyed_int(VTABLE_get_integer(INTERP, key), value);
+ }
+
+ VTABLE void set_pmc_keyed_int(INTVAL pos, PMC *value) {
+ SELF.set_string_keyed_int(pos, VTABLE_get_string(INTERP, value));
+ }
/*
=item C<void replace(STRING *orig, STRING *_new)>
Modified: branches/context_pmc3/src/pmc/timer.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/timer.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/timer.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -79,7 +79,7 @@
/* Set flags for custom GC mark and destroy. */
PObj_custom_mark_SET(SELF);
- PObj_active_destroy_SET(SELF);
+ PObj_custom_destroy_SET(SELF);
/* Set up the core struct. */
core_struct->id = 0;
Modified: branches/context_pmc3/src/pmc/undef.pmc
==============================================================================
--- branches/context_pmc3/src/pmc/undef.pmc Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/pmc/undef.pmc Thu Sep 3 10:17:39 2009 (r40952)
@@ -45,19 +45,28 @@
VTABLE_set_pmc(INTERP, SELF, other);
}
else {
- PMC * const class_ = PARROT_OBJECT(other)->_class;
- PMC *clone = VTABLE_clone(interp, other);
- void *attrs;
+ PMC * const class_ = PARROT_OBJECT(other)->_class;
+ PMC *clone = VTABLE_clone(interp, other);
+ void *attrs = PMC_data(clone);
+ PMC *meta = PMC_metadata(clone);
pmc_reuse_by_class(INTERP, SELF, class_, PObj_is_object_FLAG);
/* now swap memory without leaking it */
- attrs = PMC_data(SELF);
- PMC_data(SELF) = PMC_data(clone);
- PMC_data(clone) = attrs;
- VTABLE_destroy(interp, clone);
+ PMC_data(clone) = PMC_data(SELF);
+ PMC_data(SELF) = attrs;
- PObj_is_object_SET(SELF);
+ /* Restore metadata. */
+ if (!PMC_IS_NULL(meta)) {
+ PMC * const iter = VTABLE_get_iter(interp, meta);
+ while (VTABLE_get_bool(interp, iter)) {
+ STRING * const key = VTABLE_shift_string(interp, iter);
+ PMC * const value = VTABLE_get_pmc_keyed_str(interp, meta, key);
+ VTABLE_setprop(interp, SELF, key, value);
+ }
+ }
+ PMC_data(clone) = NULL;
+ PObj_is_object_SET(SELF);
}
}
Modified: branches/context_pmc3/src/runcore/cores.c
==============================================================================
--- branches/context_pmc3/src/runcore/cores.c Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/src/runcore/cores.c Thu Sep 3 10:17:39 2009 (r40952)
@@ -386,7 +386,7 @@
PARROT_ASSERT(debugger);
/* set the top of the stack so GC can trace it for GC-able pointers
- * see trace_system_areas() in src/cpu_dep.c */
+ * see trace_system_areas() in src/gc/system.c */
debugger->lo_var_ptr = interp->lo_var_ptr;
pio = Parrot_io_STDERR(debugger);
Modified: branches/context_pmc3/t/op/box.t
==============================================================================
--- branches/context_pmc3/t/op/box.t Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/t/op/box.t Thu Sep 3 10:17:39 2009 (r40952)
@@ -1,5 +1,5 @@
#!parrot
-# Copyright (C) 2008, Parrot Foundation.
+# Copyright (C) 2008-2009, Parrot Foundation.
# $Id$
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-.const int TESTS = 24
+.const int TESTS = 26
# must set these up before the hll_map calls later
.sub '__setup' :immediate
@@ -33,6 +33,7 @@
'box_int'()
'box_num'()
'box_string'()
+ 'box_null_string'()
.local pmc box_int_hll
box_int_hll = get_root_global [ 'for_test' ], 'box_int'
@@ -93,7 +94,20 @@
isa_ok( $P0, 'String', 'string boxed to appropriate base type from reg' )
.end
+.sub 'box_null_string'
+ null $S0
+ $P0 = box $S0
+ $S1 = $P0
+ is( $S1, '', 'NULL STRING boxed to empty String PMC' )
+
+ $P1 = clone $P0
+ $S1 = $P0
+ is( $S1, '', '... and survives clone of boxed PMC (TT #964)' )
+
+.end
+
.HLL 'for_test'
+
.sub anon :anon :init
.local pmc interp
.local pmc cint, myint
Modified: branches/context_pmc3/t/op/gc.t
==============================================================================
--- branches/context_pmc3/t/op/gc.t Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/t/op/gc.t Thu Sep 3 10:17:39 2009 (r40952)
@@ -1,20 +1,14 @@
-#!perl
+#! parrot
# Copyright (C) 2001-2009, Parrot Foundation.
-# $Id$
-
-use strict;
-use warnings;
-use lib qw( . lib ../lib ../../lib );
-use Test::More;
-use Parrot::Test tests => 18;
+# $Id: string.t 40481 2009-08-11 06:09:35Z dukeleto $
=head1 NAME
-t/op/gc.t - Garbage Collection
+t/op/gc.t - Garbage collection
=head1 SYNOPSIS
- % prove t/op/gc.t
+ % prove t/op/gc.t
=head1 DESCRIPTION
@@ -23,117 +17,129 @@
=cut
-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
- $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be one more now
- $I3 = $I2 - $I1
- print $I3
+ .include 'test_more.pir'
+ plan(140)
+
+ sweep_1()
+ sweep_0()
+ sweep_0_need_destroy_obj()
+ sweep_0_need_destroy_destroy_obj()
+ collect_count()
+ collect_toggle()
+ collect_toggle_nested()
+ vanishing_singleton_PMC()
+ vanishing_ret_continuation()
+ regsave_marked()
+ recursion_and_exceptions()
+ write_barrier_1()
+ write_barrier_2()
+ addr_registry_1()
+ addr_registry_2_int()
+ addr_registry_2_str()
+ pmc_proxy_obj_mark()
+ coro_context_ret_continuation()
+ # END_OF_TESTS
+
.end
-CODE
-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
- $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" );
- new P0, 'Undef'
- interpinfo I1, 2 # How many GC mark runs have we done already?
- needs_destroy P0
- sweep 0
- interpinfo I2, 2 # Should be one more now
- sub I3, I2, I1
- print I3
- end
-CODE
-
-pasm_output_is( <<'CODE', '10', "sweep 0, with object that need destroy/destroy" );
- new P0, 'Undef'
- needs_destroy P0
- interpinfo I1, 2 # How many GC mark runs have we done already?
- new P0, 'Undef' # kill object
- sweep 0
- interpinfo I2, 2 # Should be one more now
- sub I3, I2, I1
- sweep 0
- interpinfo I4, 2 # Should be same as last
- sub I5, I4, I2
- print I3 # These create PMCs that need early GC, so we need
- print I5 # to put them after the second sweep op.
- end
-CODE
+.sub sweep_1
+ $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS # How many GC mark runs have we done already?
+ sweep 1
+ $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be one more now
+ $I3 = $I2 - $I1
+ is($I3,1)
+.end
-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
- $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" );
- interpinfo I1, 3
- collectoff
- collect
- interpinfo I2, 3
- sub I3, I2, I1
- print I3
- print "\n"
-
- collecton
- collect
- interpinfo I4, 3
- sub I6, I4, I2
- print I6
- print "\n"
-
- end
-CODE
-0
-1
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUTPUT', "Nested collectoff/collecton" );
- interpinfo I1, 3
- collectoff
- collectoff
- collecton
- collect # This shouldn't do anything... #'
- interpinfo I2, 3
- sub I3, I2, I1
- print I3
- print "\n"
-
- collecton
- collect # ... but this should
- interpinfo I4, 3
- sub I6, I4, I2
- print I6
- print "\n"
-
- end
-CODE
-0
-1
-OUTPUT
-pir_output_is( <<'CODE', <<OUTPUT, "vanishing singleton PMC" );
-.sub main :main
+.sub sweep_0
+ $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS # How many GC mark runs have we done already?
+ sweep 0
+ $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be same
+ $I3 = $I2 - $I1
+ is($I3,0)
+.end
+
+
+# sweep 0, with object that needs destroy/destroy
+.sub sweep_0_need_destroy_obj
+ $P0 = new 'Undef'
+ $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS # How many GC mark runs have we done already?
+ needs_destroy $P0
+ sweep 0
+ $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be one more now
+ $I3 = $I2 - $I1
+ is($I3,1)
+.end
+
+
+# sweep 0, with object that needs destroy/destroy
+.sub sweep_0_need_destroy_destroy_obj
+ $P0 = new 'Undef'
+ needs_destroy $P0
+ $I1 = interpinfo .INTERPINFO_GC_MARK_RUNS # How many GC mark runs have we done already?
+ $P0 = new 'Undef' #kill object
+ sweep 0
+ $I2 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be one more now
+ $I3 = $I2 - $I1
+ sweep 0
+ $I4 = interpinfo .INTERPINFO_GC_MARK_RUNS # Should be same as last
+ $I5 = $I4 - $I2
+ is($I3,1)
+ is($I5,0)
+.end
+
+
+.sub collect_count
+ $I1 = interpinfo .INTERPINFO_GC_COLLECT_RUNS # How many garbage collections have we done already?
+ collect
+ $I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS # Should be one more now
+ $I3 = $I2 - $I1
+ is($I3,1)
+.end
+
+
+.sub collect_toggle
+ $I1 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
+ collectoff
+ collect
+ $I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
+ $I3 = $I2 - $I1
+ is($I3,0)
+
+ collecton
+ collect
+ $I4 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
+ $I6 = $I4 - $I2
+ is($I6,1)
+.end
+
+
+.sub collect_toggle_nested
+ $I1 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
+ collectoff
+ collectoff
+ collecton
+ collect # This shouldn't do anything... #'
+ $I2 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
+ $I3 = $I2 - $I1
+ is($I3,0)
+
+ collecton
+ collect # ... but this should
+ $I4 = interpinfo .INTERPINFO_GC_COLLECT_RUNS
+ $I6 = $I4 - $I2
+ is($I6,1)
+
+.end
+
+
+.sub vanishing_singleton_PMC
$P16 = new 'Env'
$P16['Foo'] = 'bar'
- $I16 = 100
+ $I16 = 100 #Why 100?
$I17 = 0
loop:
@@ -141,38 +147,27 @@
_rand()
$I17 += 1
if $I17 <= $I16 goto loop
- say "ok"
.end
.sub _rand
$P16 = new 'Env'
$P5 = $P16['Foo']
+ is($P5, 'bar')
if $P5 != 'bar' goto err
.return()
err:
- say "singleton destroyed .Env = ."
+ print "singleton destroyed .Env = ."
$P16 = new 'Env'
$S16 = typeof $P16
say $S16
.end
+# END: vanishing_singleton_PMC
-CODE
-ok
-OUTPUT
-
-pir_output_is( <<'CODE', <<OUTPUT, "vanishing return continuation in method calls" );
-.sub main :main
- .local pmc o, cl
- cl = newclass "Foo"
-
- new o, "Foo"
- print "ok\n"
- end
-.end
+# vanishing return continuation in method calls
.namespace ["Foo"]
.sub init :vtable :method
- print "init\n"
+ ok(1, "entered init()")
sweep 1
new $P6, 'String'
set $P6, "hi"
@@ -184,105 +179,81 @@
sweep 1
inc self
sweep 1
- print "back from _inc\n"
+ ok(1, "leaving do_inc")
.end
.sub __increment :method
- print "inc\n"
+ ok(1, "in __increment")
sweep 1
.end
-CODE
-init
-inc
-back from _inc
-ok
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "failing if regsave is not marked" );
- newclass P9, "Source"
- newclass P10, "Source::Buffer"
- new P12, "Source"
-
- set S20, P12
- print S20
- set S20, P12
- print S20
- end
+.namespace [ ]
+
+.sub vanishing_ret_continuation
+ .local pmc o, cl
+ cl = newclass 'Foo'
+ o = new 'Foo'
+ ok(1)
+.end
+# END: vanishing_return_continuation
+
+
+
+#Fail if regsave is not marked
.namespace ["Source"]
-.pcc_sub __get_string: # buffer
- get_params "0", P2
- getprop P12, "buffer", P2
+.sub get_string :method :vtable # buffer
+ $P4 = self
+ $P2 = getprop "buffer", $P4
sweep 1
- unless_null P12, buffer_ok
- new P12, "Source::Buffer"
- new P14, 'String'
- set P14, "hello\n"
- setprop P12, "buf", P14
- setprop P2, "buffer", P12
+ unless_null $P2, buffer_ok
+ $P2 = new "Source::Buffer"
+ $P3 = new "String"
+ $P3 = "hello"
+ $P2 = setprop "buf", $P3
+ $P4 = setprop "buffer", $P2
buffer_ok:
- set_returns "0", P12
- returncc
+ .return($P2)
+.end
.namespace ["Source::Buffer"]
-.pcc_sub __get_string:
- get_params "0", P2
+.sub get_string :method :vtable
+ $P4 = self
sweep 1
- getprop P12, "buf", P2
- set S16, P12
- set_returns "0", S16
- returncc
-CODE
-hello
-hello
-OUTPUT
+ $P2 = getprop "buf", $P4
+ $S0 = $P2
+ .return($S0)
+.end
-# this is a stripped down version of imcc/t/syn/pcc_16
-# s. also src/pmc/retcontinuation.pmc
-pasm_output_is( <<'CODE', <<OUTPUT, "coro context and invalid return continuations" );
-.pcc_sub main:
- .const 'Sub' P0 = "co1"
- set I20, 0
-l:
- get_results ''
- set_args ''
- invokecc P0
- inc I20
- lt I20, 3, l
- print "done\n"
- end
-.pcc_sub co1:
- get_params ''
- set P17, P1
-col:
- print "coro\n"
- sweep 1
- yield
- branch col
+.namespace [ ]
-CODE
-coro
-coro
-coro
-done
-OUTPUT
+.sub regsave_marked
+ $P0 = newclass "Source"
+ $P1 = newclass "Source::Buffer"
+ $P2 = new "Source"
-pir_output_is( <<'CODE', <<OUTPUT, "Recursion and exceptions" );
+ $S1 = $P2
+ is($S1, "hello")
-# this did segfault with GC_DEBUG
+ $S1 = $P2 #why are we doing this twice?
+ is($S1, "hello")
+.end
-.sub main :main
+# end regsave_marked()
+
+
+# Recursion and exceptions
+# NOTE: this did segfault with GC_DEBUG
+.sub recursion_and_exceptions
.local pmc n
$P0 = getinterp
$P0."recursion_limit"(10)
- newclass $P0, "b"
+ $P0 = newclass "b"
$P0 = new "b"
$P1 = new 'Integer'
$P1 = 0
n = $P0."b11"($P1)
- print "ok 1\n"
- print n
- print "\n"
+ ok(1)
+ is(n,8)
.end
.namespace ["b"]
.sub b11 :method
@@ -292,7 +263,8 @@
# store_lex -1, "n", n
n1 = new 'Integer'
n1 = n + 1
- push_eh catch
+ push_eh catch # we're going to catch an exception when recursion_depth
+ # is too large
n = self."b11"(n1)
# store_lex -1, "n", n
pop_eh
@@ -300,233 +272,176 @@
# n = find_lex "n"
.return(n)
.end
-CODE
-ok 1
-9
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "write barrier 1" );
- null I2
- set I3, 100
+.namespace [ ]
+
+# write barrier 1
+.sub write_barrier_1
+ null $I2
+ $I3 = 100
lp3:
- null I0
- set I1, 1000
- new P1, 'ResizablePMCArray'
+ null $I0
+ $I1 = 1000
+ $P1 = new 'ResizablePMCArray'
lp1:
- new P2, 'ResizablePMCArray'
- new P0, 'Integer'
- set P0, I0
- set P2[0], P0
- set P1[I0], P2
- if I0, not_0
- needs_destroy P0
- # force marking past P2[0]
+ $P2 = new 'ResizablePMCArray'
+ $P0 = new 'Integer'
+ $P0 = $I0
+ $P2[0] = $P0
+ $P1[$I0] = $P2
+ if $I0, not_0
+ needs_destroy $P0
+ # force marking past $P2[0]
sweep 0
not_0:
- new P3, 'Undef'
- new P4, 'Undef'
- inc I0
- lt I0, I1, lp1
+ $P3 = new 'Undef'
+ $P4 = new 'Undef'
+ inc $I0
+ lt $I0, $I1, lp1
- null I0
+ null $I0
# trace 1
lp2:
- set P2, P1[I0]
- set P2, P2[0]
- eq P2, I0, ok
+ $P2 = $P1[$I0]
+ $P2 = $P2[0]
+ eq $P2, $I0, ok
print "nok\n"
print "I0: "
- print I0
+ print $I0
print " P2: "
- print P2
+ print $P2
print " type: "
- typeof S0, P2
- print S0
+ $S0 = typeof $P2
+ print $S0
print " I2: "
- print I2
+ print $I2
print "\n"
exit 1
ok:
- inc I0
- lt I0, I1, lp2
- inc I2
- lt I2, I3, lp3
- print "ok\n"
- end
-CODE
-ok
-OUTPUT
-
-pasm_output_is( <<'CODE', <<OUTPUT, "write barrier 2 - hash" );
- null I2
- set I3, 100
+ inc $I0
+ lt $I0, $I1, lp2
+ inc $I2
+ lt $I2, $I3, lp3
+ ok(1)
+.end
+
+
+# write barrier 2 - hash
+.sub write_barrier_2
+ null $I2
+ $I3 = 100
lp3:
- null I0
- set I1, 100
- new P1, 'Hash'
+ null $I0
+ $I1 = 100
+ $P1 = new 'Hash'
lp1:
- new P2, 'Hash'
- new P0, 'Integer'
- set P0, I0
- set S0, I0
- set P2["first"], P0
- set P1[S0], P2
- if I0, not_0
- new P0, 'Integer'
- needs_destroy P0
- null P0
+ $P2 = new 'Hash'
+ $P0 = new 'Integer'
+ $P0 = $I0
+ $S0 = $I0
+ $P2["first"] = $P0
+ $P1[$S0] = $P2
+ if $I0, not_0
+ $P0 = new 'Integer'
+ needs_destroy $P0
+ null $P0
# force full sweep
sweep 0
not_0:
- new P3, 'Undef'
- new P4, 'Undef'
- inc I0
- lt I0, I1, lp1
+ $P3 = new 'Undef'
+ $P4 = new 'Undef'
+ inc $I0
+ lt $I0, $I1, lp1
- null I0
+ null $I0
# trace 1
lp2:
- set S0, I0
- set P2, P1[S0]
- set P2, P2["first"]
- eq P2, I0, ok
+ $S0 = $I0
+ $P2 = $P1[$S0]
+ $P2 = $P2["first"]
+ eq $P2, $I0, ok
print "nok\n"
print "I0: "
- print I0
+ print $I0
print " P2: "
- print P2
+ print $P2
print " type: "
- typeof S0, P2
- print S0
+ $S0 = typeof $P2
+ print $S0
print " I2: "
- print I2
+ print $I2
print "\n"
exit 1
ok:
- inc I0
- lt I0, I1, lp2
- inc I2
- lt I2, I3, lp3
- print "ok\n"
- end
-CODE
-ok
-OUTPUT
-
-pir_output_is( <<'CODE', <<'OUTPUT', "verify pmc proxy object marking" );
-.sub main :main
- .local pmc cl, s, t
- cl = subclass "String", "X"
- addattribute cl, "o3"
- addattribute cl, "o4"
- s = new "X"
- $P0 = new 'String'
- $S0 = "ok" . " 3\n"
- $P0 = $S0
- setattribute s, "o3", $P0
- $P0 = new 'String'
- $S0 = "ok" . " 4\n"
- $P0 = $S0
- setattribute s, "o4", $P0
- null $P0
- null $S0
- null cl
- sweep 1
- s = "ok 1\n"
- print s
- .local int i
- i = 0
-lp:
- t = new "X"
- inc i
- if i < 1000 goto lp
- t = "ok 2\n"
- print s
- print t
- $P0 = getattribute s, "o3"
- print $P0
- $P0 = getattribute s, "o4"
- print $P0
+ inc $I0
+ lt $I0, $I1, lp2
+ inc $I2
+ lt $I2, $I3, lp3
+ ok(1)
.end
-CODE
-ok 1
-ok 1
-ok 2
-ok 3
-ok 4
-OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "AddrRegistry 1" );
-.sub main :main
+
+
+# AddrRegistry 1
+.sub addr_registry_1
.local pmc a, reg, nil
reg = new 'AddrRegistry'
a = new 'String'
null nil
$I0 = reg[a]
if $I0 == 0 goto ok1
- print "not "
+ notok(1)
ok1:
- print "ok 1\n"
+ ok(1, "ok 1")
reg[a] = nil
$I0 = reg[a]
if $I0 == 1 goto ok2
- print "not "
+ notok(1)
ok2:
- print "ok 2\n"
+ ok(1, "ok 2")
reg[a] = nil
$I0 = reg[a]
if $I0 == 2 goto ok3
- print "not "
+ notok(1)
ok3:
- print "ok 3\n"
-
+ ok(1, "ok 3")
delete reg[a]
$I0 = reg[a]
if $I0 == 1 goto ok4
- print "not "
+ notok(1)
ok4:
- print "ok 4\n"
+ ok(1, "ok 4")
delete reg[a]
$I0 = reg[a]
if $I0 == 0 goto ok5
- print "not "
+ notok(1)
ok5:
- print "ok 5\n"
+ ok(1, "ok 5")
.end
-CODE
-ok 1
-ok 2
-ok 3
-ok 4
-ok 5
-OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "AddrRegistry 2" );
-.sub main :main
+
+# AddrRegistry 2
+.sub addr_registry_2_int
.local pmc a, b, reg, nil
null nil
reg = new 'AddrRegistry'
a = new 'String'
b = new 'String'
$I0 = elements reg
- print $I0
+ is($I0, 0)
reg[a] = nil
$I0 = elements reg
- print $I0
+ is($I0, 1)
reg[a] = nil
$I0 = elements reg
- print $I0
+ is($I0, 1)
reg[b] = nil
$I0 = elements reg
- print $I0
- print "\n"
+ is($I0, 2)
.end
-CODE
-0112
-OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "AddrRegistry 2" );
-.sub main :main
+
+# AddrRegistry 2
+.sub addr_registry_2_str
.local pmc a, b, c, reg, nil, it
null nil
reg = new 'AddrRegistry'
@@ -551,12 +466,71 @@
done:
$P1.'sort'()
$S1 = join '', $P1
- print $S1
- print "\n"
+ is($S1, 'k1k2k3')
+.end
+
+# verify pmc proxy object marking
+.sub pmc_proxy_obj_mark
+ .local pmc cl, s, t
+ cl = subclass "String", "X"
+ addattribute cl, "o3"
+ addattribute cl, "o4"
+ s = new "X"
+ $P0 = new 'String'
+ $S0 = "ok" . " 3"
+ $P0 = $S0
+ setattribute s, "o3", $P0
+ $P0 = new 'String'
+ $S0 = "ok" . " 4"
+ $P0 = $S0
+ setattribute s, "o4", $P0
+ null $P0
+ null $S0
+ null cl
+ sweep 1
+ s = "ok 1"
+ is(s, "ok 1")
+ .local int i
+ i = 0
+lp:
+ t = new "X"
+ inc i
+ if i < 1000 goto lp
+ t = "ok 2"
+ is(s, "ok 1")
+ is(t, "ok 2")
+ $P0 = getattribute s, "o3"
+ is($P0, "ok 3")
+ $P0 = getattribute s, "o4"
+ is($P0, "ok 4")
+.end
+
+
+# coro context and invalid return continuations
+# this is a stripped down version of imcc/t/syn/pcc_16
+# s. also src/pmc/retcontinuation.pmc
+
+.sub coro_context_ret_continuation
+ .const 'Sub' $P0 = "co1"
+ $I20 = 0
+l:
+ get_results ''
+ set_args ''
+ invokecc $P0
+ inc $I20
+ lt $I20, 3, l
+ ok(1, "done\n")
+.end
+
+.sub co1
+ get_params ''
+ $P17 = $P1
+col:
+ ok(1, "coro\n")
+ sweep 1
+ yield
+ branch col
.end
-CODE
-k1k2k3
-OUTPUT
=head1 SEE ALSO
@@ -567,11 +541,9 @@
F<examples/benchmarks/primes2.c>,
F<examples/benchmarks/primes2.py>.
-=cut
-
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
-# vim: expandtab shiftwidth=4:
+# vim: expandtab shiftwidth=4 filetype=pir:
Modified: branches/context_pmc3/t/op/string.t
==============================================================================
--- branches/context_pmc3/t/op/string.t Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/t/op/string.t Thu Sep 3 10:17:39 2009 (r40952)
@@ -1,5 +1,5 @@
#!perl
-# Copyright (C) 2001-2008, Parrot Foundation.
+# Copyright (C) 2001-2009, Parrot Foundation.
# $Id$
use strict;
@@ -7,7 +7,7 @@
use lib qw( . lib ../lib ../../lib );
use Test::More;
-use Parrot::Test tests => 166;
+use Parrot::Test tests => 167;
use Parrot::Config;
=head1 NAME
@@ -55,6 +55,13 @@
Bar
OUTPUT
+pasm_output_is( <<'CODE', <<'OUTPUT', 'clone null' );
+ null S0
+ clone S1, S0
+ end
+CODE
+OUTPUT
+
pasm_output_is( <<'CODE', '4', 'length_i_s' );
set I4, 0
set S4, "JAPH"
Added: branches/context_pmc3/t/pmc/integer-old.t
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/context_pmc3/t/pmc/integer-old.t Thu Sep 3 10:17:39 2009 (r40952)
@@ -0,0 +1,54 @@
+#!perl
+# Copyright (C) 2001-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/integer-old.t - Perl tests for Integer basic type
+
+=head1 SYNOPSIS
+
+ % prove t/pmc/integer.t
+
+=head1 DESCRIPTION
+
+Perl tests the Integer PMC. These should be translated to PIR when possible.
+
+=cut
+
+
+pir_error_output_like( <<'CODE',qr/get_as_base: base out of bounds/ms, "get_as_base() bounds check" );
+.sub main :main
+ $P0 = new ['Integer']
+ $P0 = 42
+
+ $S0 = $P0.'get_as_base'(1)
+
+ say $S0
+.end
+CODE
+
+pir_error_output_like( <<'CODE', qr/get_as_base: base out of bounds/ms,"get_as_base() bounds check" );
+.sub main :main
+ $P0 = new ['Integer']
+ $P0 = 42
+
+ $S0 = $P0.'get_as_base'(37)
+
+ say $S0
+.end
+CODE
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Modified: branches/context_pmc3/t/pmc/integer.t
==============================================================================
--- branches/context_pmc3/t/pmc/integer.t Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/t/pmc/integer.t Thu Sep 3 10:17:39 2009 (r40952)
@@ -1,14 +1,7 @@
-#!perl
-# Copyright (C) 2001-2008, Parrot Foundation.
+#!parrot
+# Copyright (C) 2001-2009, Parrot Foundation.
# $Id$
-use strict;
-use warnings;
-use lib qw( . lib ../lib ../../lib );
-
-use Test::More;
-use Parrot::Test tests => 19;
-
=head1 NAME
t/pmc/integer.t - Integer basic type
@@ -23,372 +16,297 @@
=cut
-pir_output_is( << 'CODE', << 'OUTPUT', "basic math" );
+.sub 'test' :main
+ .include 'test_more.pir'
+
+ plan(58)
+ test_basic_math()
+ test_truthiness_and_definedness()
+ test_set_string_native()
+ test_isa()
+ test_interface()
+ test_ne()
+ test_gt()
+ test_ge()
+ test_istrue_isfalse()
+ test_if_unless()
+ test_add()
+ test_arithmetic()
+ test_get_as_base()
+ test_get_as_base10()
+ test_get_as_base_various()
+ test_cmp_subclass()
+ test_cmp_RT59336()
+.end
-.sub _main
+
+.sub test_basic_math
.local pmc int_1
int_1 = new ['Integer']
- print int_1
- print "\n"
+ is(int_1,0)
int_1 = 1
- print int_1
- print "\n"
+ is(int_1,1)
int_1 += 777777
int_1 -= 777776
- print int_1
- print "\n"
+ is(int_1,2)
int_1 *= -333333
int_1 /= -222222
- print int_1
- print "\n"
+ is(int_1,3)
inc int_1
inc int_1
dec int_1
- print int_1
- print "\n"
+ is(int_1,4)
neg int_1
dec int_1
neg int_1
- print int_1
- print "\n"
- end
+ is(int_1,5)
.end
-CODE
-0
-1
-2
-3
-4
-5
-OUTPUT
-pir_output_is( << 'CODE', << 'OUTPUT', "truth and definedness" );
-.sub _main
+.sub test_truthiness_and_definedness
.local pmc int_1
int_1 = new ['Integer']
- print "A newly created Integer is "
- if int_1 goto LABEL_1
- print "not "
-LABEL_1:
- print "true.\n"
+ nok(int_1, "A newly created Integer is not true")
.local int is_defined
is_defined = defined int_1
- print "A newly created Integer is "
- if is_defined goto LABEL_2
- print " not "
-LABEL_2:
- print "defined.\n"
+
+ nok(int_1, "A newly created Integer is not defined")
int_1 = -999999999
- print "The Integer "
- print int_1
- print " is "
- if is_defined goto LABEL_3
- print "not "
-LABEL_3:
- print "true.\n"
+
+ ok(int_1, "-999999999 is true")
is_defined = defined int_1
- print "The Integer "
- print int_1
- print " is "
- if is_defined goto LABEL_4
- print "not "
-LABEL_4:
- print "defined.\n"
- end
+
+ ok(int_1, "-999999999 is defined")
+
.end
-CODE
-A newly created Integer is not true.
-A newly created Integer is defined.
-The Integer -999999999 is true.
-The Integer -999999999 is defined.
-OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "set_string_native" );
-.sub _main
+.sub test_set_string_native
.local pmc pmc1
pmc1 = new ['Integer']
pmc1 = "-123456789"
- print pmc1
- print "\n"
- end
+ is(pmc1, -123456789)
.end
-CODE
--123456789
-OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "isa" );
-.sub _main
+.sub test_isa
.local pmc pmc1
pmc1 = new ['Integer']
.local int pmc1_is_a
pmc1_is_a = isa pmc1, "Integer"
- print "A newly created Integer is "
- if pmc1_is_a goto PMC1_IS_A_INTEGER
- print "not "
-PMC1_IS_A_INTEGER:
- print "an Integer.\n"
-
- end
+ isa_ok(pmc1, "Integer")
.end
-CODE
-A newly created Integer is an Integer.
-OUTPUT
-pir_output_is( << 'CODE', << 'OUTPUT', "check whether interface is done" );
-
-.sub _main
+.sub test_interface
.local pmc pmc1
pmc1 = new ['Integer']
.local int bool1
does bool1, pmc1, "scalar"
- print bool1
- print "\n"
+ is(bool1,1)
does bool1, pmc1, "integer"
- print bool1
- print "\n"
+ is(bool1,1)
does bool1, pmc1, "no_interface"
- print bool1
- print "\n"
- end
+ is(bool1,0)
.end
-CODE
-1
-1
-0
-OUTPUT
-pir_output_is( << 'CODE', << 'OUTPUT', "Comparison ops: ne" );
-
-.sub _main
+.sub test_ne
.local pmc pmc1
pmc1 = new ['Integer']
.local int int1
pmc1 = 10
int1 = 20
ne pmc1, int1, OK1
- print "not "
+ ok(0)
+ goto next_test
OK1:
- print "ok 1\n"
+ ok(1)
+
+next_test:
+
int1 = 10
ne pmc1, int1, BAD2
branch OK2
BAD2:
- print "not "
+ ok(0)
+ goto fin
OK2:
- print "ok 2\n"
- end
+ ok(1)
+fin:
.end
-CODE
-ok 1
-ok 2
-OUTPUT
-pir_output_is( << 'CODE', << 'OUTPUT', "Comparison ops: gt" );
-.sub _main
+.sub test_gt
.local pmc pmc1
pmc1 = new ['Integer']
.local int int1
pmc1 = 10
int1 = 5
gt pmc1, int1, OK1
- print "not "
+ ok(0)
+ goto next_test1
OK1:
- print "ok 1\n"
+ ok(1)
+
+next_test1:
int1 = 10
gt pmc1, int1, BAD2
branch OK2
BAD2:
- print "not "
+ ok(0)
OK2:
- print "ok 2\n"
+ ok(1)
+
+next_test2:
int1 = 20
gt pmc1, int1, BAD3
branch OK3
BAD3:
- print "not "
+ ok(0)
+ goto fin
OK3:
- print "ok 3\n"
- end
+ ok(1)
+fin:
.end
-CODE
-ok 1
-ok 2
-ok 3
-OUTPUT
-pir_output_is( << 'CODE', << 'OUTPUT', "Comparison ops: ge" );
-.sub _main
+.sub test_ge
.local pmc pmc1
pmc1 = new ['Integer']
.local int int1
pmc1 = 10
int1 = 5
ge pmc1, int1, OK1
- print "not "
+ ok(0)
+ goto next_test1
OK1:
- print "ok 1\n"
+ ok(1)
int1 = 10
+
+next_test1:
ge pmc1, int1, OK2
- print "not "
+ ok(0)
+ goto next_test2
OK2:
- print "ok 2\n"
+ ok(1)
int1 = 20
+next_test2:
ge pmc1, int1, BAD3
branch OK3
BAD3:
- print "not "
+ ok(0)
+ goto fin
OK3:
- print "ok 3\n"
- end
+ ok(1)
+fin:
.end
-CODE
-ok 1
-ok 2
-ok 3
-OUTPUT
-pir_output_is( << 'CODE', << 'OUTPUT', "Logical ops: istrue & isfalse" );
-.sub _main
+.sub test_istrue_isfalse
.local pmc pmc1
pmc1 = new ['Integer']
.local int int1
pmc1 = 10
istrue int1, pmc1
- print int1
- print "\n"
+ is(1,int1)
isfalse int1, pmc1
- print int1
- print "\n"
+ is(0,int1)
pmc1 = 0
istrue int1, pmc1
- print int1
- print "\n"
+ is(0,int1)
isfalse int1, pmc1
- print int1
- print "\n"
-
- end
+ is(1,int1)
.end
-CODE
-1
-0
-0
-1
-OUTPUT
-pasm_output_is( <<'CODE', <<'OUTPUT', "if/unless with Integer PMC" );
- new P0, ['Integer']
- set P0, 10
- if P0, OK1
- print "not "
-OK1: print "ok 1\n"
- unless P0, BAD2
+
+.sub test_if_unless
+ new $P0, ['Integer']
+ set $P0, 10
+ if $P0, OK1
+ ok(0)
+ goto test1
+OK1:
+ ok(1)
+test1:
+ unless $P0, BAD2
branch OK2
-BAD2: print "not "
-OK2: print "ok 2\n"
- set P0, 0
- if P0, BAD3
+BAD2:
+ ok(0)
+ goto test2
+OK2:
+ ok(1)
+ set $P0, 0
+test2:
+ if $P0, BAD3
branch OK3
-BAD3: print "not "
-OK3: print "ok 3\n"
- unless P0, OK4
- print "not "
-OK4: print "ok 4\n"
- end
-CODE
-ok 1
-ok 2
-ok 3
-ok 4
-OUTPUT
-
-pasm_output_is( <<'CODE', <<'OUT', "add" );
- new P0, ['Integer']
- set P0, 5
- new P1, ['Integer']
- set P1, 10
- new P2, ['Integer']
- add P2, P0, P1
- set S0, P2
- print S0
- print "\n"
- set P0, "20"
- set P1, "30"
- add P2, P1, P0
- set S0, P2
- print S0
- print "\n"
- end
-CODE
-15
-50
-OUT
+BAD3:
+ ok(0)
+ goto test3
+OK3:
+ ok(1)
+test3:
+ unless $P0, OK4
+ ok(0)
+ goto fin
+OK4:
+ ok(1)
+fin:
+.end
+
+.sub test_add
+ new $P0, ['Integer']
+ set $P0, 5
+ new $P1, ['Integer']
+ set $P1, 10
+ new $P2, ['Integer']
+ add $P2, $P0, $P1
+ set $S0, $P2
+ is($S0,15)
+ set $P0, "20"
+ set $P1, "30"
+ add $P2, $P1, $P0
+ set $S0, $P2
+ is($S0,50)
+.end
-pir_output_is( << 'CODE', << 'OUTPUT', "<oper>" );
-.sub main :main
+.sub test_arithmetic
$P0 = new ['Integer']
$P1 = new ['Integer']
set $P0, 6
set $P1, 2
add $P2, $P0, $P1
- print $P2
- print "\n"
+ is($P2,8)
$P2 = add $P0, $P1
- print $P2
- print "\n"
+ is($P2,8)
sub $P2, $P0, $P1
- print $P2
- print "\n"
+ is($P2,4)
mul $P2, $P0, $P1
- print $P2
- print "\n"
+ is($P2,12)
div $P2, $P0, $P1
- print $P2
- print "\n"
+ is($P2,3)
mod $P2, $P0, $P1
- print $P2
- print "\n"
+ is($P2,0)
pow $P2, $P0, $P1
- print $P2
- print "\n"
+ is($P2,36)
.end
-CODE
-8
-8
-4
-12
-3
-0
-36
-OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "can get_as_base()" );
-.sub main :main
+
+.sub test_get_as_base
$P0 = new ['Integer']
$P0 = 42
$I0 = can $P0, 'get_as_base'
- if $I0, OK
- print "not "
-OK: print "ok\n"
+ ok($I0,'Integers can get_as_base')
.end
-CODE
-ok
-OUTPUT
-pir_error_output_like( <<'CODE', <<'OUTPUT', "get_as_base() bounds check" );
+=pod
+
+pir_error_output_like( <<'CODE',qr/get_as_base: base out of bounds/ms, "get_as_base() bounds check" );
.sub main :main
$P0 = new ['Integer']
$P0 = 42
@@ -418,84 +336,55 @@
.*/
OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', "get_as_base(10)" );
-.sub main :main
+=cut
+
+.sub test_get_as_base10
$P0 = new ['Integer']
$P0 = 42
$S0 = $P0.'get_as_base'(10)
-
- print $S0
- print "\n"
+ is($S0,42)
.end
-CODE
-42
-OUTPUT
-
-pir_output_is( <<'CODE', <<'OUTPUT', "get_as_base(various)" );
-.sub main :main
- .local pmc jmpstack
- jmpstack = new 'ResizableIntegerArray'
+.sub test_get_as_base_various
$P0 = new ['Integer']
$P0 = 42
$S0 = $P0.'get_as_base'(2)
- local_branch jmpstack, PRINT
+ is($S0,101010)
$S0 = $P0.'get_as_base'(3)
- local_branch jmpstack, PRINT
+ is($S0,1120)
$S0 = $P0.'get_as_base'(5)
- local_branch jmpstack, PRINT
+ is($S0,132)
$S0 = $P0.'get_as_base'(7)
- local_branch jmpstack, PRINT
+ is($S0,60)
$S0 = $P0.'get_as_base'(11)
- local_branch jmpstack, PRINT
+ is($S0,39)
$S0 = $P0.'get_as_base'(13)
- local_branch jmpstack, PRINT
+ is($S0,33)
$S0 = $P0.'get_as_base'(17)
- local_branch jmpstack, PRINT
+ is($S0,28)
$S0 = $P0.'get_as_base'(19)
- local_branch jmpstack, PRINT
+ is($S0,24)
$S0 = $P0.'get_as_base'(23)
- local_branch jmpstack, PRINT
+ is($S0,'1j')
$S0 = $P0.'get_as_base'(29)
- local_branch jmpstack, PRINT
+ is($S0,'1d')
$S0 = $P0.'get_as_base'(31)
- local_branch jmpstack, PRINT
- goto END
-
-PRINT:
- print $S0
- print "\n"
- local_return jmpstack
-END:
+ is($S0,'1b')
.end
-CODE
-101010
-1120
-132
-60
-39
-33
-28
-24
-1j
-1d
-1b
-OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', 'cmp functions for subclasses' );
-.sub main :main
+.sub test_cmp_subclass
$P0 = subclass 'Integer', 'Int'
$P1 = new ['Int']
@@ -504,43 +393,32 @@
$P2 = 2
$I0 = cmp $P1, $P2
- say $I0
+ is($I0,-1)
$I0 = cmp $P1, $P1
- say $I0
+ is($I0,0)
$I0 = cmp $P2, $P1
- say $I0
+ is($I0,1)
.end
-CODE
--1
-0
-1
-OUTPUT
-pir_output_is( <<'CODE', <<'OUTPUT', 'cmp for Integers more than 2^31 apart, RT #59336' );
-.sub 'main' :main
+.sub test_cmp_RT59336
$P0 = new ['Integer']
$P0 = 2147483600
- test_10:
- print $P0
- print " is"
- if $P0 > -10 goto skip_10
- print " not"
- skip_10:
- say " greater than -10"
-
- test_1000:
- print $P0
- print " is"
- if $P0 > -1000 goto skip_1000
- print " not"
- skip_1000:
- say " greater than -1000"
+test_10:
+ if $P0 > -10 goto pass
+ ok(0)
+ goto test_1000
+pass:
+ ok(1)
+
+test_1000:
+ if $P0 > -1000 goto pass2
+ ok(0)
+ goto fin
+pass2:
+ ok(1)
+fin:
.end
-CODE
-2147483600 is greater than -10
-2147483600 is greater than -1000
-OUTPUT
# Local Variables:
# mode: cperl
Modified: branches/context_pmc3/t/pmc/packfiledirectory.t
==============================================================================
--- branches/context_pmc3/t/pmc/packfiledirectory.t Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/t/pmc/packfiledirectory.t Thu Sep 3 10:17:39 2009 (r40952)
@@ -136,7 +136,7 @@
delete_seg:
delete pfdir[$S0]
dec $I0
- $I1 = elements pfdir
+ $I1 = elements pfdir
is($I0, $I1, "segment deleted")
done:
Modified: branches/context_pmc3/t/pmc/packfilerawsegment.t
==============================================================================
--- branches/context_pmc3/t/pmc/packfilerawsegment.t Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/t/pmc/packfilerawsegment.t Thu Sep 3 10:17:39 2009 (r40952)
@@ -22,11 +22,13 @@
# get_integer_keyed_int doesn't return all zeroes either.
.include 't/pmc/testlib/packfile_common.pir'
+.include 'packfile_segments.pasm'
.sub 'main' :main
.include 'test_more.pir'
- plan(2)
+ plan(5)
test_elements()
test_get_integer()
+ test_type()
.end
# PackfileRawSegment.elements
@@ -60,6 +62,38 @@
ok($I0, "PackfileRawSegment.get_integer_keyed_int returns some data")
.end
+# PackfileRawSegment.type
+.sub 'test_type'
+ .local pmc pf, pfdir, pfseg, hash, it
+ pf = _pbc()
+ pfdir = pf.'get_directory'()
+ hash = new ['Hash']
+ # annotations.pbc contains all available segments. -1 for directory and unknown.
+ # So, in hash we should have 5 elements.
+ it = iter pfdir
+ loop:
+ unless it goto done
+ $S0 = shift it
+ $P0 = pfdir[$S0]
+ $I0 = $P0.'type'()
+ hash[$I0] = 1
+ goto loop
+
+ done:
+ $I0 = elements hash
+ is($I0, 5, "Got all types of Packfile segments")
+
+ # Now create RawSegment and set type.
+ $P0 = new ['PackfileRawSegment']
+ $I0 = $P0.'type'()
+ is($I0, .PF_BYTEC_SEG, "Default type is PF_BYTEC_SEG")
+
+ $P0.'type'(.PF_DEBUG_SEG)
+ $I0 = $P0.'type'()
+ is($I0, .PF_DEBUG_SEG, "Type successfully changed")
+
+.end
+
# Local Variables:
# mode: cperl
Modified: branches/context_pmc3/t/pmc/string.t
==============================================================================
--- branches/context_pmc3/t/pmc/string.t Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/t/pmc/string.t Thu Sep 3 10:17:39 2009 (r40952)
@@ -20,7 +20,7 @@
.sub main :main
.include 'test_more.pir'
- plan(165)
+ plan(171)
set_or_get_strings()
setting_integers()
@@ -71,7 +71,7 @@
exception_to_int_2()
exception_to_int_3()
assign_null_string()
-
+ access_keyed()
# END_OF_TESTS
.end
@@ -1018,6 +1018,39 @@
is( $I0, 0, 'assign null string, TT #729' )
.end
+.sub access_keyed
+ .local pmc s
+ s = new ['String']
+ s = "BAR" # Second character is zero, not 'o'
+
+ # Get
+ $S0 = s[0]
+ is($S0, 'B', 'Get string by index')
+
+ $I0 = s[1]
+ $I1 = ord 'A'
+ is($I0, $I1, 'Get integer by index')
+
+ $P0 = s[2]
+ is($P0, 'R', 'Get PMC by index')
+
+ # Set
+ s = new ['String']
+
+ $S0 = 'f'
+ s[0] = $S0
+ is(s, 'f', 'Set string keyed')
+
+ $I0 = ord 'o'
+ s[1] = $I0
+ is(s, 'fo', 'Set integer keyed')
+
+ $P0 = new ['String']
+ $P0 = 'o'
+ s[2] = $P0
+ is(s, 'foo', 'Set PMC keyed')
+.end
+
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
Modified: branches/context_pmc3/tools/dev/fetch_languages.pl
==============================================================================
--- branches/context_pmc3/tools/dev/fetch_languages.pl Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/tools/dev/fetch_languages.pl Thu Sep 3 10:17:39 2009 (r40952)
@@ -60,6 +60,12 @@
},
{
+ name => 'blizkost',
+ scm => 'GIT',
+ repository => 'git://github.com/jnthn/blizkost.git'
+ },
+
+ {
name => 'c99',
scm => 'SVN',
repository => 'https://svn.parrot.org/languages/c99/trunk'
Added: branches/context_pmc3/tools/dev/parrot_shell.pl
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/context_pmc3/tools/dev/parrot_shell.pl Thu Sep 3 10:17:39 2009 (r40952)
@@ -0,0 +1,182 @@
+#! perl
+# Copyright (C) 2009, Parrot Foundation.
+# $Id$
+
+use 5.008;
+use strict;
+use warnings;
+use FindBin qw($Bin);
+use lib "$Bin/../lib"; # install location
+use lib "$Bin/../../lib"; # build location
+use IO::File ();
+use File::Spec;
+use Parrot::Config;
+use File::Temp qw/ tempfile /;
+use Benchmark qw/timeit timestr :hireswallclock/;
+
+=head1 NAME
+
+tools/dev/parrot_shell.pl - The Parrot Shell
+
+=head1 SYNOPSIS
+
+ % perl tools/dev/parrot_shell.pl
+
+=head1 DESCRIPTION
+
+The Parrot Shell allows you to rapidly prototype Parrot code. It wraps your code
+in a ".sub main" and ".end", so you don't have to, unless your code begins with
+".sub". It reads code from STDIN until it sees a line containing a single ".",
+which is how you tell parrot_shell to run the code you are giving to it:
+
+Example:
+ parrot_shell 0> $I0 = 42
+ $N1 = sqrt $I0
+ say $N1
+ .
+ Output:
+ 6.48074069840786
+
+ parrot_shell 1> quit
+ Thanks for visiting the Parrot Shell, come back soon!
+
+Each numbered Parrot Shell session is run in its own interpreter, so no registers
+or variables are shared/leaked between them.
+
+=cut
+
+my $parrot;
+my $session_no = 0;
+
+BEGIN {
+ $parrot = File::Spec->catfile( ".", "parrot");
+ unless (-e $parrot) {
+ warn "$parrot not found, attempting to use an installed parrot";
+ $parrot = 'parrot';
+ }
+ my $exefile = $parrot . $PConfig{exe};
+}
+
+show_welcome();
+
+while(1) {
+ my $code;
+ show_prompt($session_no);
+
+ while( my $line = <STDIN> ) {
+ exit_shell() if $line =~ m/^q(uit)?$/;
+
+ if ($line =~ m/^h(elp)?$/) {
+ show_help();
+ show_prompt($session_no) if !defined $code;
+ next;
+ }
+ if ($line =~ m/^\s*\.\s*$/) { # Run it, baby!
+ print eval_snippet($code);
+ last;
+ }
+ else {
+ $code .= $line;
+ }
+ }
+
+ $session_no++;
+}
+
+sub show_welcome {
+ print <<BIENVENIDO;
+Welcome to the Parrot Shell, it's experimental!
+Type h or help for some basic help
+Type q or quit to flee the madness
+BIENVENIDO
+
+}
+
+sub show_prompt {
+ my ($session_no) = @_;
+ print "\nparrot_shell $session_no> ";
+}
+sub exit_shell {
+ print "Thanks for visiting the Parrot Shell, come back soon!\n";
+ exit 0;
+}
+
+sub show_help {
+ print <<'EX';
+
+The Parrot Shell allows you to rapidly prototype Parrot code. It wraps your code
+in a ".sub main" and ".end", so you don't have to, unless your code begins with
+".sub". It reads code from STDIN until it sees a line containing a single ".",
+which is how you tell parrot_shell to run the code you are giving to it:
+
+Example:
+ parrot_shell> $I0 = 42
+ $N1 = sqrt $I0
+ say $N1
+ .
+ Output:
+ 6.48074069840786
+EX
+}
+
+sub eval_snippet {
+ my ($snippet) = @_;
+ my $codefn = get_tempfile();
+ my $stdoutfn = get_tempfile();
+ my $f = IO::File->new(">$codefn");
+
+ $f->print(normalize_snippet($snippet || ''));
+ $f->close();
+
+ my $time = timestr(timeit(1, sub { system("$parrot $codefn >$stdoutfn 2>&1") } ));
+ $time =~ s/\(.*//g;
+
+ handle_errors($?) if $?;
+
+ $f = IO::File->new($stdoutfn);
+
+ my $output = join( '', <$f> );
+ return "Time: $time\nOutput:\n$output";
+}
+
+sub handle_errors {
+ my ($exit_code) = @_;
+ if ($exit_code == -1) {
+ print "Error: failed to execute: $!\n";
+ }
+ elsif ($exit_code & 127) {
+ printf "Error: child died with signal %d, %s coredump\n",
+ ($exit_code & 127), ($exit_code & 128) ? 'with' : 'without';
+ }
+ else {
+ printf "Error: child exited with value %d\n", $? >> 8;
+ }
+}
+
+sub get_tempfile {
+ my (undef, $name) = tempfile( CLEANUP => 1);
+ return $name;
+}
+
+sub normalize_snippet {
+ my ($snippet) = @_;
+
+ if ($snippet =~ m/^\.sub/) {
+ # don't wrap snippet
+ return $snippet;
+ }
+ else {
+ return <<SNIP;
+.sub main :main
+$snippet
+.end
+SNIP
+ }
+}
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Modified: branches/context_pmc3/tools/dev/pbc_to_exe.pir
==============================================================================
--- branches/context_pmc3/tools/dev/pbc_to_exe.pir Thu Sep 3 08:27:30 2009 (r40951)
+++ branches/context_pmc3/tools/dev/pbc_to_exe.pir Thu Sep 3 10:17:39 2009 (r40952)
@@ -79,6 +79,7 @@
if (!interp)
return 1;
+ Parrot_init_stacktop(interp, &interp);
Parrot_set_executable_name(interp,
Parrot_str_new(interp, argv[0], 0));
Parrot_set_flag(interp, PARROT_DESTROY_FLAG);
More information about the parrot-commits
mailing list