|
|
Author: jkeenan
Date: Thu Feb 14 16:52:34 2008
New Revision: 25721
Added:
branches/tcif/lib/Parrot/Harness/
- copied from r25719, /tags/tcif-25718/lib/Parrot/Harness/
branches/tcif/lib/Parrot/Harness/DefaultTests.pm
- copied unchanged from r25719,
/tags/tcif-25718/lib/Parrot/Harness/DefaultTests.pm
branches/tcif/lib/Parrot/Harness/Options.pm
- copied unchanged from r25719,
/tags/tcif-25718/lib/Parrot/Harness/Options.pm
branches/tcif/lib/Parrot/Harness/Smoke.pm
- copied unchanged from r25719,
/tags/tcif-25718/lib/Parrot/Harness/Smoke.pm
branches/tcif/t/pharness/
- copied from r25719, /tags/tcif-25718/t/pharness/
branches/tcif/t/pharness/01-default_tests.t
- copied unchanged from r25719,
/tags/tcif-25718/t/pharness/01-default_tests.t
branches/tcif/t/pharness/02-get_test_prog_args.t
- copied unchanged from r25719,
/tags/tcif-25718/t/pharness/02-get_test_prog_args.t
branches/tcif/t/pharness/03-handle_long_options.t
- copied unchanged from r25719,
/tags/tcif-25718/t/pharness/03-handle_long_options.t
branches/tcif/t/pharness/04-Usage.t
- copied unchanged from r25719, /tags/tcif-25718/t/pharness/04-Usage.t
Removed:
branches/tcif/languages/perl6/src/parser/regex.pir
Modified:
branches/tcif/DEPRECATED.pod
branches/tcif/MANIFEST
branches/tcif/compilers/imcc/imc.c
branches/tcif/compilers/imcc/imcc.l
branches/tcif/compilers/imcc/sets.c
branches/tcif/compilers/imcc/symreg.c
branches/tcif/config/gen/makefiles/root.in
branches/tcif/docs/embed.pod
branches/tcif/docs/imcc/imcc.pod
branches/tcif/include/parrot/exceptions.h
branches/tcif/include/parrot/intlist.h
branches/tcif/include/parrot/list.h
branches/tcif/include/parrot/pmc.h
branches/tcif/languages/perl6/src/builtins/traits.pir
branches/tcif/languages/perl6/src/classes/Junction.pir
branches/tcif/languages/perl6/src/classes/Object.pir
branches/tcif/languages/perl6/src/parser/actions.pm
branches/tcif/languages/perl6/src/parser/grammar.pg
branches/tcif/languages/perl6/src/parser/quote_expression.pir
branches/tcif/languages/t/harness
branches/tcif/lib/Parrot/Configure/Options/Test.pm
branches/tcif/lib/Parrot/Distribution.pm
branches/tcif/src/debug.c
branches/tcif/src/exceptions.c
branches/tcif/src/intlist.c
branches/tcif/src/library.c
branches/tcif/src/list.c
branches/tcif/src/ops/string.ops
branches/tcif/src/pmc.c
branches/tcif/src/pmc/class.pmc
branches/tcif/src/string.c
branches/tcif/t/codingstd/linelength.t
branches/tcif/t/harness
branches/tcif/tools/build/headerizer.pl
branches/tcif/tools/build/nativecall.pl
branches/tcif/tools/dev/pbc_to_exe_gen.pl
Log:
Synchronizing tcif branch with recent submissions to trunk, particularly
refactoring of t/harness.
Modified: branches/tcif/DEPRECATED.pod
==============================================================================
--- branches/tcif/DEPRECATED.pod (original)
+++ branches/tcif/DEPRECATED.pod Thu Feb 14 16:52:34 2008
@@ -231,14 +231,3 @@
PCT follows the specification given by pdd26 .
=back
-
-=head1 Misc
-
-=over 4
-
-=item * 'v' NCI arg signature [post 0.5.1]
-
-See RT #48733. (Been removed for some time; nice warning is going away)
-
-=back
-
Modified: branches/tcif/MANIFEST
==============================================================================
--- branches/tcif/MANIFEST (original)
+++ branches/tcif/MANIFEST Thu Feb 14 16:52:34 2008
@@ -1,7 +1,7 @@
# ex: set ro:
# $Id$
#
-# generated by tools/dev/mk_manifest_and_skip.pl Wed Feb 13 00:12:24 2008 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Thu Feb 14 23:47:46 2008 UT
#
# See tools/dev/install_files.pl for documentation on the
# format of this file.
@@ -1818,7 +1818,6 @@
languages/perl6/src/parser/grammar-oper.pg [perl6]
languages/perl6/src/parser/grammar.pg [perl6]
languages/perl6/src/parser/quote_expression.pir [perl6]
-languages/perl6/src/parser/regex.pir [perl6]
languages/perl6/src/pmc/perl6bool.pmc [perl6]
languages/perl6/src/pmc/perl6str.pmc [perl6]
languages/perl6/src/pmc/perl6undef.pmc [perl6]
@@ -2460,6 +2459,9 @@
lib/Parrot/Docs/Section/Perl.pm [devel]
lib/Parrot/Docs/Section/Tests.pm [devel]
lib/Parrot/Docs/Section/Tools.pm [devel]
+lib/Parrot/Harness/DefaultTests.pm [devel]
+lib/Parrot/Harness/Options.pm [devel]
+lib/Parrot/Harness/Smoke.pm [devel]
lib/Parrot/Headerizer.pm [devel]
lib/Parrot/IO/Directory.pm [devel]
lib/Parrot/IO/File.pm [devel]
@@ -3204,6 +3206,10 @@
t/perl/Parrot_PIR_Formatter.t []
t/perl/Parrot_Test.t []
t/perl/README []
+t/pharness/01-default_tests.t []
+t/pharness/02-get_test_prog_args.t []
+t/pharness/03-handle_long_options.t []
+t/pharness/04-Usage.t []
t/pmc/addrregistry.t []
t/pmc/array.t []
t/pmc/bigint.t []
Modified: branches/tcif/compilers/imcc/imc.c
==============================================================================
--- branches/tcif/compilers/imcc/imc.c (original)
+++ branches/tcif/compilers/imcc/imc.c Thu Feb 14 16:52:34 2008
@@ -11,7 +11,7 @@
=head1 DESCRIPTION
-Main entry point and top level of IMCC compiler.
+Routines for handling imc_units, which represent subs.
Moved all register allocation and spill code to reg_alloc.c
@@ -52,7 +52,8 @@
=item C<void imc_compile_all_units>
-RT#48260: Not yet documented!!!
+Compile all imc_units, and free all memory of instructions
+and structures afterwards.
=cut
@@ -62,6 +63,7 @@
void
imc_compile_all_units(PARROT_INTERP)
{
+ /* compile all units created during the parse */
IMC_Unit *unit;
#if ! COMPILE_IMMEDIATE
for (unit = IMCC_INFO(interp)->imc_units; unit;) {
@@ -71,8 +73,10 @@
}
#endif
emit_close(interp, NULL);
- /* All done with compilation, now free instructions and other structures */
+ /* All done with compilation, now free all memory allocated
+ * for instructions and other structures.
+ */
for (unit = IMCC_INFO(interp)->imc_units; unit;) {
IMC_Unit * const unit_next = unit->next;
Instruction *ins;
@@ -215,7 +219,7 @@
=item C<static void imc_free_unit>
-RT#48260: Not yet documented!!!
+Free all memory allocated of an IMC_Unit structure.
=cut
Modified: branches/tcif/compilers/imcc/imcc.l
==============================================================================
--- branches/tcif/compilers/imcc/imcc.l (original)
+++ branches/tcif/compilers/imcc/imcc.l Thu Feb 14 16:52:34 2008
@@ -1199,9 +1199,6 @@
char *s = Parrot_locate_runtime_file(interp, file_name,
PARROT_RUNTIME_FT_INCLUDE);
- if (!s)
- IMCC_fataly(interp, E_IOError, strerror(errno));
-
file = fopen(s, "r");
mem_sys_free(s);
Modified: branches/tcif/compilers/imcc/sets.c
==============================================================================
--- branches/tcif/compilers/imcc/sets.c (original)
+++ branches/tcif/compilers/imcc/sets.c Thu Feb 14 16:52:34 2008
@@ -1,6 +1,6 @@
/*
* $Id$
- * Copyright (C) 2002-2007, The Perl Foundation.
+ * Copyright (C) 2002-2008, The Perl Foundation.
*/
/*
@@ -40,7 +40,7 @@
=item C<Set* set_make>
-RT#48260: Not yet documented!!!
+Create a new Set object.
=cut
@@ -51,9 +51,9 @@
Set*
set_make(int length)
{
- Set * const s = mem_allocate_typed(Set);
+ Set * const s = mem_allocate_zeroed_typed(Set);
s->length = length;
- s->bmp = (unsigned char
*)mem_sys_allocate_zeroed(NUM_BYTES(length));
+ s->bmp = mem_allocate_n_zeroed_typed(NUM_BYTES(length), unsigned
char);
return s;
}
@@ -61,7 +61,7 @@
=item C<Set* set_make_full>
-RT#48260: Not yet documented!!!
+Create a new Set object and clear all bits.
=cut
@@ -85,7 +85,7 @@
=item C<void set_free>
-RT#48260: Not yet documented!!!
+Free memory allocated for the Set argument.
=cut
@@ -103,7 +103,7 @@
=item C<void set_clear>
-RT#48260: Not yet documented!!!
+Clear all bits in the Set argument.
=cut
@@ -214,7 +214,7 @@
int i, j;
for (i = 0; i < NUM_BYTES(s->length); ++i) {
- int set_byte = s->bmp[i];
+ const int set_byte = s->bmp[i];
if (set_byte == 0xFF)
continue;
@@ -232,7 +232,8 @@
=item C<int set_contains>
-RT#48260: Not yet documented!!!
+Check whether the specified element is present in the
+specified Set argument. Returns 1 if it is, 0 otherwise.
=cut
@@ -259,7 +260,11 @@
=item C<Set * set_union>
-RT#48260: Not yet documented!!!
+Compute the union of the two Set arguments. A new
+resulting Set object is returned.
+
+If the two Set arguments have different lengths, a
+fatal error is raised.
=cut
@@ -288,7 +293,12 @@
=item C<Set * set_intersec>
-RT#48260: Not yet documented!!!
+Create a new Set object that is the intersection of the
+Set arguments. Intersection is defined through the binary
+and operator.
+
+If the argument Sets don't have the same length, a fatal
+error is raised.
=cut
@@ -317,7 +327,9 @@
=item C<void set_intersec_inplace>
-RT#48260: Not yet documented!!!
+See set_intersec, except that the first argument Set
+is changed inplace; in other words, the first Set argument
+becomes the result.
=cut
Modified: branches/tcif/compilers/imcc/symreg.c
==============================================================================
--- branches/tcif/compilers/imcc/symreg.c (original)
+++ branches/tcif/compilers/imcc/symreg.c Thu Feb 14 16:52:34 2008
@@ -851,7 +851,7 @@
SymReg *
_mk_address(PARROT_INTERP, ARGMOD(SymHash *hsh), ARGIN(const char *name), int
uniq)
{
- SymReg * r;
+ SymReg *r;
if (uniq == U_add_all) {
r = mem_allocate_zeroed_typed(SymReg);
@@ -982,7 +982,7 @@
=item C<SymReg * mk_label_address>
-RT#48260: Not yet documented!!!
+Wrapper for _mk_address.
=cut
@@ -1153,7 +1153,9 @@
=item C<void free_sym>
-RT#48260: Not yet documented!!!
+Free all memory of the specified SymReg.
+If it has a pcc_sub_t entry, free all memory of that
+structure as well.
=cut
@@ -1188,7 +1190,7 @@
=item C<void create_symhash>
-RT#48260: Not yet documented!!!
+Create a symbol hash table with space for 16 entries.
=cut
@@ -1197,7 +1199,7 @@
void
create_symhash(ARGOUT(SymHash *hash))
{
- hash->data = (SymReg**)mem_sys_allocate_zeroed(16 * sizeof (SymReg*));
+ hash->data = (SymReg **)mem_sys_allocate_zeroed(16 * sizeof (SymReg *));
hash->size = 16;
hash->entries = 0;
}
@@ -1206,7 +1208,7 @@
=item C<static void resize_symhash>
-RT#48260: Not yet documented!!!
+Resize a symbol hash table.
=cut
@@ -1215,21 +1217,20 @@
static void
resize_symhash(ARGMOD(SymHash *hsh))
{
- SymHash nh;
- const int new_size = hsh->size << 1;
- int i;
+ SymHash nh; /* new symbol table */
+ const int new_size = hsh->size << 1; /* new size is twice as large */
+ int i; /* for loop index */
SymReg ** next_r;
int n_next;
- nh.data = mem_allocate_n_zeroed_typed(new_size, SymReg*);
+ nh.data = mem_allocate_n_zeroed_typed(new_size, SymReg *);
n_next = 16;
- next_r = mem_allocate_n_zeroed_typed(n_next, SymReg*);
+ next_r = mem_allocate_n_zeroed_typed(n_next, SymReg *);
for (i = 0; i < hsh->size; i++) {
- SymReg *r;
- SymReg *next;
- int j = 0;
- int k;
+ SymReg *r, *next;
+ int j = 0, k;
+
for (r = hsh->data[i]; r; r = next) {
next = r->next;
/*
@@ -1248,15 +1249,18 @@
for (k = 0; k < j; ++k) {
int new_i;
r = next_r[k];
+ /* recompute hash for this symbol: */
new_i = hash_str(r->name) % new_size;
r->next = nh.data[new_i];
nh.data[new_i] = r;
}
}
+ /* free memory of old hash table */
mem_sys_free(hsh->data);
mem_sys_free(next_r);
+ /* let the hashtable's data pointers point to the new data */
hsh->data = nh.data;
hsh->size = new_size;
}
@@ -1291,7 +1295,7 @@
=item C<void store_symreg>
-RT#48260: Not yet documented!!!
+Wrapper for _store_symreg.
=cut
@@ -1397,7 +1401,9 @@
=item C<SymReg * find_sym>
-RT#48260: Not yet documented!!!
+Wrapper for _find_sym; only if there's a current
+IMC_Unit, will _find_sym be invoked; otherwise NULL
+is returned.
=cut
@@ -1420,7 +1426,8 @@
=item C<void clear_sym_hash>
-RT#48260: Not yet documented!!!
+Free all memory of the symbols in the specified
+hash table.
=cut
@@ -1455,7 +1462,7 @@
=item C<void debug_dump_sym_hash>
-RT#48260: Not yet documented!!!
+Print all identifiers in the specified hash table.
=cut
@@ -1535,7 +1542,7 @@
=item C<unsigned int hash_str>
-RT#48260: Not yet documented!!!
+Compute the hash value for the string argument.
=cut
Modified: branches/tcif/config/gen/makefiles/root.in
==============================================================================
--- branches/tcif/config/gen/makefiles/root.in (original)
+++ branches/tcif/config/gen/makefiles/root.in Thu Feb 14 16:52:34 2008
@@ -745,6 +745,7 @@
@echo " splint: Code checking with splint."
@echo " headerizer: Recreate header files for C-source files"
@echo " apilist: Show list of PARROT_API functions"
+ @echo " malloclist: Show list of PARROT_MALLOC functions"
@echo " cover: Run test suite coverage analysis."
@echo ""
@echo "Release:"
@@ -1393,11 +1394,13 @@
OPS2PMUTILS_DIR = t/tools/ops2pmutils
OPS2CUTILS_DIR = t/tools/ops2cutils
REVISIONUTILS_DIR = t/tools/revision
+HARNESS_DIR = t/pharness
BUILDTOOLS_TEST_FILES = \
$(PMC2CUTILS_DIR)/*.t \
$(OPS2PMUTILS_DIR)/*.t \
$(OPS2CUTILS_DIR)/*.t \
- $(REVISIONUTILS_DIR)/*.t
+ $(REVISIONUTILS_DIR)/*.t \
+ $(HARNESS_DIR)/*.t
MANIFEST_DIR = t/manifest
MANIFEST_TEST_FILES = \
$(MANIFEST_DIR)/01-basic.t \
@@ -2207,7 +2210,10 @@
$(PERL) $(BUILD_TOOLS_DIR)/headerizer.pl $(HEADERIZER_O_FILES)
apilist: $(SRC_DIR)/core_pmcs.c
- $(PERL) $(BUILD_TOOLS_DIR)/headerizer.pl --apilist $(HEADERIZER_O_FILES)
+ $(PERL) $(BUILD_TOOLS_DIR)/headerizer.pl --macro=PARROT_API
$(HEADERIZER_O_FILES)
+
+malloclist: $(SRC_DIR)/core_pmcs.c
+ $(PERL) $(BUILD_TOOLS_DIR)/headerizer.pl --macro=PARROT_MALLOC
$(HEADERIZER_O_FILES)
###############################################################################
#
Modified: branches/tcif/docs/embed.pod
==============================================================================
--- branches/tcif/docs/embed.pod (original)
+++ branches/tcif/docs/embed.pod Thu Feb 14 16:52:34 2008
@@ -228,7 +228,8 @@
exiting, the function calls all registered exit handlers in LIFO order.
C<Parrot_really_destroy()> is usually called as the last exit handler.
-=item C<void Parrot_on_exit(Parrot_Interp interp, void
(*handler)(Parrot_Interp, int, void *), void *arg)>
+=item C<void Parrot_on_exit(Parrot_Interp interp,
+ void (*handler)(Parrot_Interp, int, void *), void
*arg)>
Registers an exit handler to be called from C<Parrot_exit()> in LIFO order.
The handler function should accept as arguments an interpreter, an integer
@@ -377,11 +378,11 @@
=over 4
=item C<void *Parrot_call_sub(Parrot_Interp interp, Parrot_PMC sub, const_char
*signature)>
-
+
Call a Parrot subroutine that returns a pointer using the supplied signature.
=item C<Parrot_Int Parrot_call_sub_ret_int(Parrot_Interp interp, Parrot_PMC
sub, const_char *signature)>
-
+
Call a Parrot subroutine that returns an integer using the supplied signature.
=item C<Parrot_Float Parrot_call_sub_ret_float(Parrot_Interp interp,
Parrot_PMC sub, const_char *signature)>
@@ -407,7 +408,7 @@
constructor (see init versus init_pmc). Use C<PMCNULL> if you are not
supplying an argument.
-=back
+=back
=head3 Calling methods
Modified: branches/tcif/docs/imcc/imcc.pod
==============================================================================
--- branches/tcif/docs/imcc/imcc.pod (original)
+++ branches/tcif/docs/imcc/imcc.pod Thu Feb 14 16:52:34 2008
@@ -1,4 +1,4 @@
-# Copyright (C) 2001-2005, The Perl Foundation.
+# Copyright (C) 2001-2008, The Perl Foundation.
# $Id$
=head1 NAME
@@ -11,7 +11,7 @@
integrated into the C<parrot> executable.
IMCC compiles a language called Parrot Intermediate Representation (PIR).
-PIR is the primary target of language implementations. PIR code files usually
+PIR is the primary target of language implementations. PIR code files
have the extension C<.pir>.
See L<docs/pdds/draft/pdd19_pir.pod> for the most recent documentation on PIR.
@@ -19,8 +19,6 @@
This document describes available IMCC documentation, located in
F<docs/imcc> unless otherwise described.
-See also the general Parrot documentation, located in F<docs>.
-
=head1 DESCRIPTION
=head2 imcfaq.pod
Modified: branches/tcif/include/parrot/exceptions.h
==============================================================================
--- branches/tcif/include/parrot/exceptions.h (original)
+++ branches/tcif/include/parrot/exceptions.h Thu Feb 14 16:52:34 2008
@@ -304,7 +304,7 @@
#ifdef NDEBUG
# define PARROT_ASSERT(x) ((void)0)
#else
-# define PARROT_ASSERT(x) Parrot_assert(x, #x, __FILE__, __LINE__)
+# define PARROT_ASSERT(x) Parrot_assert((int)(x), #x, __FILE__, __LINE__)
#endif
Modified: branches/tcif/include/parrot/intlist.h
==============================================================================
--- branches/tcif/include/parrot/intlist.h (original)
+++ branches/tcif/include/parrot/intlist.h Thu Feb 14 16:52:34 2008
@@ -48,7 +48,7 @@
__attribute__nonnull__(2)
FUNC_MODIFIES(*l);
-PARROT_MALLOC
+PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
IntList * intlist_clone(PARROT_INTERP, ARGIN(const IntList *list))
__attribute__nonnull__(1)
@@ -76,7 +76,7 @@
__attribute__nonnull__(2)
FUNC_MODIFIES(*l);
-PARROT_MALLOC
+PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
IntList * intlist_new(PARROT_INTERP)
__attribute__nonnull__(1);
Modified: branches/tcif/include/parrot/list.h
==============================================================================
--- branches/tcif/include/parrot/list.h (original)
+++ branches/tcif/include/parrot/list.h Thu Feb 14 16:52:34 2008
@@ -95,7 +95,7 @@
FUNC_MODIFIES(*list);
PARROT_API
-PARROT_MALLOC
+PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
List * list_clone(PARROT_INTERP, ARGIN(const List *other))
__attribute__nonnull__(1)
@@ -140,7 +140,7 @@
FUNC_MODIFIES(*list);
PARROT_API
-PARROT_MALLOC
+PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
List * list_new(PARROT_INTERP, PARROT_DATA_TYPE type)
__attribute__nonnull__(1);
Modified: branches/tcif/include/parrot/pmc.h
==============================================================================
--- branches/tcif/include/parrot/pmc.h (original)
+++ branches/tcif/include/parrot/pmc.h Thu Feb 14 16:52:34 2008
@@ -49,7 +49,7 @@
PARROT_API
PARROT_CANNOT_RETURN_NULL
-PARROT_MALLOC
+PARROT_WARN_UNUSED_RESULT
PMC * pmc_new(PARROT_INTERP, INTVAL base_type)
__attribute__nonnull__(1);
Modified: branches/tcif/languages/perl6/src/builtins/traits.pir
==============================================================================
--- branches/tcif/languages/perl6/src/builtins/traits.pir (original)
+++ branches/tcif/languages/perl6/src/builtins/traits.pir Thu Feb 14
16:52:34 2008
@@ -19,6 +19,13 @@
.param pmc child
addparent child, parent
.end
+.sub 'trait_auxiliary:is' :multi('Perl6ProtoObject', 'Class')
+ .param pmc parent
+ .param pmc child
+ parent = parent.HOW()
+ 'trait_auxiliary:is'(parent, child)
+.end
+
=back
Modified: branches/tcif/languages/perl6/src/classes/Junction.pir
==============================================================================
--- branches/tcif/languages/perl6/src/classes/Junction.pir (original)
+++ branches/tcif/languages/perl6/src/classes/Junction.pir Thu Feb 14
16:52:34 2008
@@ -47,8 +47,9 @@
=cut
.sub '!values' :method
- .param pmc list
- setattribute self, "@values", list
+ .param pmc l
+ l = 'list'(l :flat)
+ setattribute self, "@values", l
.end
@@ -70,29 +71,6 @@
.end
-=item pick()
-
-Gets a random value from the junction.
-
-=cut
-
-.sub 'pick' :method
- # Need to know the number of elements.
- .local pmc values
- values = getattribute self, "@values"
- .local int elems
- elems = elements values
-
- # Get random index.
- .local int idx
- idx = 'prefix:rand'(elems)
-
- # Return that value.
- $P0 = values[idx]
- .return($P0)
-.end
-
-
=item clone
Clone v-table method.
Modified: branches/tcif/languages/perl6/src/classes/Object.pir
==============================================================================
--- branches/tcif/languages/perl6/src/classes/Object.pir (original)
+++ branches/tcif/languages/perl6/src/classes/Object.pir Thu Feb 14
16:52:34 2008
@@ -132,6 +132,88 @@
.return (protoobject)
.end
+=item !keyword_class(name)
+
+Internal helper method to create a class.
+
+=cut
+
+.sub '!keyword_class' :method
+ .param string name
+ .local pmc class, resolve_list, methods, iter
+
+ # Create class.
+ class = newclass name
+
+ # Set resolve list to include all methods of the class.
+ methods = inspect class, 'methods'
+ iter = new 'Iterator', methods
+ resolve_list = new 'ResizableStringArray'
+resolve_loop:
+ unless iter goto resolve_loop_end
+ $P0 = shift iter
+ push resolve_list, $P0
+ goto resolve_loop
+resolve_loop_end:
+ class.resolve_method(resolve_list)
+
+ .return(class)
+.end
+
+=item !keyword_role(name)
+
+Internal helper method to create a role.
+
+=cut
+
+.sub '!keyword_role' :method
+ .param string name
+ .local pmc info, role
+
+ # Need to make sure it ends up attached to the right
+ # namespace.
+ info = new 'Hash'
+ info['name'] = name
+ $P0 = new 'ResizablePMCArray'
+ $P0[0] = name
+ info['namespace'] = $P0
+
+ # Create role.
+ role = new 'Role', info
+
+ # XXX s/root/hll/ when we start using .HLL
+ set_root_global name, role
+
+ .return(role)
+.end
+
+=item !keyword_does(class, role_name)
+
+Internal helper method to implement the functionality of the does keyword.
+
+=cut
+
+.sub '!keyword_does' :method
+ .param pmc class
+ .param string role_name
+ .local pmc role
+ # XXX s/root/hll/ when we start using .HLL
+ role = get_root_global role_name
+ addrole class, role
+.end
+
+=item !keyword_has(class, attr_name)
+
+Adds an attribute with the given name to the class.
+
+=cut
+
+.sub '!keyword_has' :method
+ .param pmc class
+ .param string attr_name
+ addattribute class, attr_name
+.end
+
=back
=head2 Object methods
Modified: branches/tcif/languages/perl6/src/parser/actions.pm
==============================================================================
--- branches/tcif/languages/perl6/src/parser/actions.pm (original)
+++ branches/tcif/languages/perl6/src/parser/actions.pm Thu Feb 14 16:52:34 2008
@@ -11,6 +11,11 @@
# Attatch any initialization code.
our $?INIT;
if defined( $?INIT ) {
+ $?INIT.unshift(PAST::Var.new(
+ :name('$def'),
+ :scope('lexical'),
+ :isdecl(1)
+ ));
$?INIT.blocktype('declaration');
$?INIT.pirflags(':init :load');
$past.unshift( $?INIT );
@@ -501,39 +506,26 @@
if $<sym> eq 'class' || $<sym> eq 'role' {
my $decl_past := PAST::Stmts.new();
- # Apply any traits and do any roles.
- my $traits_pir := '';
- my $does_pir := '';
- for $<trait_or_does> {
- if $_<trait> {
- # Apply the trait.
- if $_<trait><trait_auxiliary><sym> eq 'is' {
- $traits_pir := $traits_pir ~
- " $P1 = get_hll_global '" ~
$_<trait><trait_auxiliary><ident> ~ "'\n" ~
- " $P1 = $P1.HOW()\n" ~
- " 'trait_auxiliary:is'($P1, $P0)\n";
- }
- }
- elsif $_<sym> eq 'does' {
- # Role.
- $does_pir := $does_pir ~
- " $P1 = get_hll_global '" ~ ~$_<name> ~ "'\n" ~
- " addrole $P0, $P1\n";
- }
- }
-
# If it's a class...
if $<sym> eq 'class' {
- # Build class PIR.
- my $class_pir;
- if $traits_pir eq '' {
- $class_pir := " $P0 = subclass 'Perl6Object', '" ~
$<name> ~ "'\n";
- }
- else {
- $class_pir := " $P0 = newclass '" ~ $<name> ~ "'\n" ~
$traits_pir;
- }
- $decl_past.push(PAST::Op.new( :inline($class_pir ~ $does_pir)
));
-
+ # Call method to create the class.
+ $decl_past.push(PAST::Op.new(
+ :pasttype('bind'),
+ PAST::Var.new(
+ :name('$def'),
+ :scope('lexical')
+ ),
+ PAST::Op.new(
+ :pasttype('callmethod'),
+ :name('!keyword_class'),
+ PAST::Var.new(
+ :name('Perl6Object'),
+ :scope('package')
+ ),
+ PAST::Val.new( :value(~$<name>) )
+ )
+ ));
+
# Put current class, if any, on @?CLASS list so we can handle
# nested classes.
@?CLASS.unshift( $?CLASS );
@@ -546,18 +538,23 @@
# If it's a role...
elsif $<sym> eq 'role' {
- # XXX Haven't implemented roles passing along inheritance as
- # an implementation detail yet.
- if $traits_pir ne '' {
- $/.panic("Cannot apply traits to roles yet.");
- }
-
- # Build role PIR.
- my $role_pir := " $P1 = new 'Hash'\n" ~
- " $P1['name'] = '" ~ $<name> ~ "'\n" ~
- " $P0 = new 'Role', $P1\n" ~
- " set_hll_global '" ~ $<name> ~ "', $P0\n";
- $decl_past.push(PAST::Op.new( :inline($role_pir ~ $does_pir)
));
+ # Call method to create the role.
+ $decl_past.push(PAST::Op.new(
+ :pasttype('bind'),
+ PAST::Var.new(
+ :name('$def'),
+ :scope('lexical')
+ ),
+ PAST::Op.new(
+ :pasttype('callmethod'),
+ :name('!keyword_role'),
+ PAST::Var.new(
+ :name('Perl6Object'),
+ :scope('package')
+ ),
+ PAST::Val.new( :value(~$<name>) )
+ )
+ ));
# Put current role, if any, on @?ROLE list so we can handle
# nested roles.
@@ -568,6 +565,44 @@
@?PACKAGE.unshift( $?PACKAGE );
$?PACKAGE := $?ROLE;
}
+
+ # Apply any traits and do any roles.
+ my $does_pir;
+ for $<trait_or_does> {
+ if $_<trait> {
+ # Apply the trait.
+ if $_<trait><trait_auxiliary><sym> eq 'is' {
+ $?PACKAGE.push(PAST::Op.new(
+ :pasttype('call'),
+ :name('trait_auxiliary:is'),
+ PAST::Var.new(
+ :name(~$_<trait><trait_auxiliary><ident>),
+ :scope('package')
+ ),
+ PAST::Var.new(
+ :name('$def'),
+ :scope('lexical')
+ )
+ ));
+ }
+ }
+ elsif $_<sym> eq 'does' {
+ # Role.
+ $?PACKAGE.push(PAST::Op.new(
+ :pasttype('callmethod'),
+ :name('!keyword_does'),
+ PAST::Var.new(
+ :name('Perl6Object'),
+ :scope('package')
+ ),
+ PAST::Var.new(
+ :name('$def'),
+ :scope('lexical')
+ ),
+ PAST::Val.new( :value(~$_<name>) )
+ ));
+ }
+ }
}
else {
# It's a module. We need a way to mark that the current package is
@@ -587,16 +622,36 @@
$past.pirflags(':init :load');
if $<sym> eq 'class' {
- # Generate PIR to make proto-object.
- my $pir := " $P1 = get_hll_global ['Perl6Object'],
'make_proto'\n" ~
- " $P1($P0, '" ~ $<name> ~ "')\n";
- $?CLASS.push(PAST::Op.new( :inline($pir) ));
+ # Make proto-object.
+ $?CLASS.push(PAST::Op.new(
+ :pasttype('call'),
+ PAST::Var.new(
+ :scope('package'),
+ :namespace('Perl6Object'),
+ :name('make_proto')
+ ),
+ PAST::Var.new(
+ :scope('lexical'),
+ :name('$def')
+ ),
+ PAST::Val.new( :value(~$<name>) )
+ ));
- # Attatch class declaration to the init code.
+ # Attatch any class initialization code to the init code;
+ # note that we skip blocks, which are method accessors that
+ # we want to put under this block so they get the correct
+ # namespace.
unless defined( $?INIT ) {
$?INIT := PAST::Block.new();
}
- $?INIT.push( $?CLASS );
+ for @( $?CLASS ) {
+ if $_.WHAT() eq 'Block' {
+ $past.push( $_ );
+ }
+ else {
+ $?INIT.push( $_ );
+ }
+ }
# Restore outer class.
$?CLASS := @?CLASS.shift();
@@ -692,8 +747,19 @@
# Generate PIR for attribute (always name it with ! twigil).
my $variable := $<scoped><variable_decl><variable>;
$name := ~$variable<sigil> ~ '!' ~ ~$variable<name>;
- my $pir := " addattribute $P0, '" ~ $name ~ "'\n";
- $class_def.push( PAST::Op.new( :inline($pir) ) );
+ $class_def.push(PAST::Op.new(
+ :pasttype('callmethod'),
+ :name('!keyword_has'),
+ PAST::Var.new(
+ :name('Perl6Object'),
+ :scope('package')
+ ),
+ PAST::Var.new(
+ :name('$def'),
+ :scope('lexical')
+ ),
+ PAST::Val.new( :value($name) )
+ ));
# If we have no twigil, make $name as an alias to $!name.
if $variable<twigil>[0] eq '' {
@@ -1014,83 +1080,29 @@
}
-# Builds the PAST for a sub or method call, including auto-threading of
-# junctions.
-sub make_call_past($/, $callee_past, $args_past) {
- my $past;
+method regex_declarator($/, $key) {
+ make $( $/{$key} );
+}
- # Build non-junctional call.
- my $call := PAST::Op.new( :node($/),
- :pasttype('call')
- );
- if $callee_past.WHAT() eq 'Val' {
- $call.name( $callee_past.value() );
- }
- else {
- $call.push( $callee_past );
- }
- for @($args_past) {
- $call.push( $_ );
- }
- # Build short-circuiting OR to look for junctional parameters.
- my $unless_list;
- my $num_args := 0;
- for @($args_past) {
- # If it's a value, we need not check it.
- unless $_.WHAT() eq 'Val' {
- # Build "is it a junction" check code.
- my $check := PAST::Op.new( :name('infix:eq'),
- :pasttype('call'),
- :node($/)
- );
- my $what := PAST::Op.new( :name('WHAT'),
- :pasttype('callmethod'),
- :node($/),
- $_
- );
- $check.push( $what );
- $check.push( PAST::Val.new( :value( "Junction" ) ) );
+method regex_declarator_regex($/) {
+ my $past := $( $<quote_expression> );
+ $past.name( ~$<ident>[0] );
+ make $past;
+}
- if $num_args == 0 {
- $unless_list := $check
- }
- else {
- # Need to upgrade to an unless statement.
- $unless_list := PAST::Op.new( :pasttype('unless'),
- :node($/),
- $check,
- $unless_list
- );
- }
- $num_args := $num_args + 1;
- }
- }
+method regex_declarator_token($/) {
+ my $past := $( $<quote_expression> );
+ $past.name( ~$<ident>[0] );
+ make $past;
+}
- # If we had no args we need to check, it's easy.
- if $num_args == 0 {
- $past := $call;
- }
- else {
- # Need to build if statement to do the check.
- $past := PAST::Op.new( :pasttype('if'),
- :node( $/ ),
- $unless_list
- );
- my $junc_disp := PAST::Op.new( :pasttype('call'),
- :node( $/ ),
- :name( '!junction_dispatcher' )
- );
- $junc_disp.push( $callee_past );
- for @($args_past) {
- $junc_disp.push( $_ );
- }
- $past.push( $junc_disp ); # then - when we have junctions
- $past.push( $call ); # else - when we don't.
- }
- $past
+method regex_declarator_rule($/) {
+ my $past := $( $<quote_expression> );
+ $past.name( ~$<ident>[0] );
+ make $past;
}
Modified: branches/tcif/languages/perl6/src/parser/grammar.pg
==============================================================================
--- branches/tcif/languages/perl6/src/parser/grammar.pg (original)
+++ branches/tcif/languages/perl6/src/parser/grammar.pg Thu Feb 14 16:52:34 2008
@@ -432,12 +432,13 @@
| <subcall> {*} #= subcall
| <value> {*} #= value
| <statement_prefix> {*} #= statement_prefix
+ | <regex_declarator> {*} #= regex_declarator
| 'self' {*} #= self
}
rule package_declarator {
- $<sym>=[module|class|role]
+ $<sym>=[module|class|role|grammar]
<name>
<trait_or_does>* {*} #= open
[
@@ -585,6 +586,32 @@
{*}
}
+# These regex rules are some way off STD.pm at the moment, but we'll work them
+# closer to it over time.
+rule regex_declarator {
+ | <regex_declarator_regex> {*} #= regex_declarator_regex
+ | <regex_declarator_token> {*} #= regex_declarator_token
+ | <regex_declarator_rule> {*} #= regex_declarator_rule
+}
+
+rule regex_declarator_regex {
+ $<sym>='regex'
+ <ident>?
+ <before '{'> <quote_expression: :regex> {*}
+}
+
+rule regex_declarator_token {
+ $<sym>='token'
+ <ident>?
+ <before '{'> <quote_expression: :token> {*}
+}
+
+rule regex_declarator_rule {
+ $<sym>='rule'
+ <ident>?
+ <before '{'> <quote_expression: :rule> {*}
+}
+
## S05 shows semilist as being a list of statements, in order
## to support multidimensional argument lists. For now we
## just handle a single-dimensional argument list.
Modified: branches/tcif/languages/perl6/src/parser/quote_expression.pir
==============================================================================
--- branches/tcif/languages/perl6/src/parser/quote_expression.pir
(original)
+++ branches/tcif/languages/perl6/src/parser/quote_expression.pir Thu Feb
14 16:52:34 2008
@@ -82,12 +82,17 @@
options['stop'] = stop
## handle :regex parsing
+ .local pmc p6regex, quote_regex
$I0 = options['regex']
- unless $I0 goto word_start
+ if $I0 goto regex_start
+ $I0 = options['token']
+ if $I0 goto regex_start
+ $I0 = options['rule']
+ if $I0 goto regex_start
+ goto word_start
regex_start:
- .local pmc p6regex, quote_regex
- mob.'to'(pos)
p6regex = get_root_global ['parrot';'PGE::Perl6Regex'], 'regex'
+ mob.'to'(pos)
quote_regex = p6regex(mob, options :flat :named)
unless quote_regex goto fail
pos = quote_regex.'to'()
Modified: branches/tcif/languages/t/harness
==============================================================================
--- branches/tcif/languages/t/harness (original)
+++ branches/tcif/languages/t/harness Thu Feb 14 16:52:34 2008
@@ -127,28 +127,18 @@
Test::Harness::runtests(@tests);
}
else {
+ my $html_fn = "languages_smoke.html";
my @smoke_config_vars = qw(
- osname
- archname
- cc
- build_dir
- cpuarch
- revision
- VERSION
- optimize
- DEVEL
+ osname archname cc build_dir cpuarch revision VERSION optimize DEVEL
);
eval {
require Test::TAP::HTMLMatrix;
require Test::TAP::Model::Visual;
};
- die "You must have Test::TAP::HTMLMatrix installed.\n\n$@" if $@;
+ die "You must have Test::TAP::HTMLMatrix installed.\n\n$@"
+ if $@;
- ## FIXME: ###
- # This is a temporary solution until Test::TAP::Model version
- # 0.05. At that point, this function should be removed, and the
- # verbose line below should be uncommented.
{
no warnings qw/redefine once/;
*Test::TAP::Model::run_tests = sub {
@@ -163,8 +153,8 @@
my $data;
print STDERR "- $file\n";
$data = $self->run_test($file);
- $stats{tests} += $data->{results}{max};
- $stats{ok} += $data->{results}{ok} || 0;
+ $stats{tests} += $data->{results}{max} || 0;
+ $stats{ok} += $data->{results}{ok} || 0;
}
printf STDERR "%s OK from %s tests (%.2f%% ok)\n\n",
@@ -172,7 +162,7 @@
$stats{tests},
$stats{ok} / $stats{tests} * 100;
- $self->{meat}{end_time} = time;
+ $self->{meat}{end_time} = time();
};
my $start = time();
@@ -193,7 +183,6 @@
$v->has_inline_css(1); # no separate css file
- my $html_fn = "languages_smoke.html";
open HTML, '>', $html_fn;
print HTML $v->html();
close HTML;
Modified: branches/tcif/lib/Parrot/Configure/Options/Test.pm
==============================================================================
--- branches/tcif/lib/Parrot/Configure/Options/Test.pm (original)
+++ branches/tcif/lib/Parrot/Configure/Options/Test.pm Thu Feb 14 16:52:34 2008
@@ -62,6 +62,7 @@
glob("t/tools/ops2cutils/*.t"),
glob("t/tools/ops2pmutils/*.t"),
glob("t/tools/revision/*.t"),
+ glob("t/pharness/*.t"),
);
sub new {
Modified: branches/tcif/lib/Parrot/Distribution.pm
==============================================================================
--- branches/tcif/lib/Parrot/Distribution.pm (original)
+++ branches/tcif/lib/Parrot/Distribution.pm Thu Feb 14 16:52:34 2008
@@ -181,7 +181,7 @@
source => {
c => { file_exts => ['c'] },
pmc => { file_exts => ['pmc'] },
- pir => { file_exts => ['pir'] },
+ pir => { file_exts => ['pir', 't'] },
ops => { file_exts => ['ops'] },
lex => {
file_exts => ['l'],
@@ -520,11 +520,60 @@
sub get_pir_language_files {
my $self = shift;
- my @pir_files = ( $self->pir_source_files, );
+ # make sure we're picking up pir files (i.e. look for the shebang line)
+ my @pir_files;
+ for my $file ( $self->pir_source_files ) {
+ push @pir_files, $file
+ if $self->is_pir( $file->path );
+ }
return @pir_files;
}
+=item C<is_pir()>
+
+Determines if the given filename is PIR source
+
+=cut
+
+# Since .t files might be written in any language, we can't *just* check the
+# filename to see if something should be treated as PIR.
+sub is_pir {
+ my $self = shift;
+ my $filename = shift;
+
+ if ( !-f $filename ) {
+ return 0;
+ }
+
+ # .pir files should always be tested
+ if ( $filename =~ /\.pir$/ ) {
+ return 1;
+ }
+
+ # test files (.t) files might need testing.
+ # ignore everything else.
+ if ( $filename !~ /\.t$/ ) {
+ return 0;
+ }
+
+ # Now let's check to see if there's a plain parrot shebang.
+ open my $file_handle, '<', $filename
+ or $self->_croak("Could not open $filename for reading");
+ my $line = <$file_handle>;
+ close $file_handle;
+
+ if ( $line && $line =~ /^#!.*parrot/ ) {
+ # something that specifies a pir or pbc is probably a HLL, skip it
+ if ($line =~ /\.(?:pir|pbc)/) {
+ return 0;
+ }
+ return 1;
+ }
+
+ return 0;
+}
+
=item C<file_for_perl_module($module)>
Returns the Perl module file for the specified module.
Modified: branches/tcif/src/debug.c
==============================================================================
--- branches/tcif/src/debug.c (original)
+++ branches/tcif/src/debug.c Thu Feb 14 16:52:34 2008
@@ -1437,6 +1437,8 @@
Escapes C<">, C<\r>, C<\n>, C<\t>, C<\a> and C<\\>.
+The returned string must be freed.
+
=cut
*/
Modified: branches/tcif/src/exceptions.c
==============================================================================
--- branches/tcif/src/exceptions.c (original)
+++ branches/tcif/src/exceptions.c Thu Feb 14 16:52:34 2008
@@ -972,8 +972,8 @@
Parrot_assert(int condition, ARGIN(const char *condition_string),
ARGIN(const char *file), unsigned int line)
{
- if ( !condition )
- Parrot_confess(condition_string, file, line );
+ if (!condition)
+ Parrot_confess(condition_string, file, line);
}
/*
@@ -1015,12 +1015,6 @@
/* stolen from http://www.delorie.com/gnu/docs/glibc/libc_665.html */
void *array[BACKTRACE_DEPTH];
size_t i;
-# ifndef BACKTRACE_VERBOSE
- int ident;
- char *caller;
- size_t callerLength;
- size_t j;
-# endif
const size_t size = backtrace(array, BACKTRACE_DEPTH);
char ** const strings = backtrace_symbols(array, size);
@@ -1030,15 +1024,17 @@
size, BACKTRACE_DEPTH);
# ifndef BACKTRACE_VERBOSE
for (i = 0; i < size; i++) {
- /* always ident */
- ident = 2; /* initial indent */
- ident += 2 * i; /* nesting depth */
- fprintf(stderr, "%*s", ident, "");
+ /* always indent */
+ const int indent = 2 + (2*i);
+ const char *caller = strchr(strings[i], '(');
+
+ fprintf(stderr, "%*s", indent, "");
/* if the caller was an anon function then strchr won't
find a '(' in the string and will return NULL */
- caller = strchr(strings[i], '(');
if (caller) {
+ size_t callerLength;
+ size_t j;
/* skip over the '(' */
caller++;
/* find the end of the symbol name */
Modified: branches/tcif/src/intlist.c
==============================================================================
--- branches/tcif/src/intlist.c (original)
+++ branches/tcif/src/intlist.c Thu Feb 14 16:52:34 2008
@@ -1,5 +1,5 @@
/*
-Copyright (C) 2001-2007, The Perl Foundation.
+Copyright (C) 2001-2008, The Perl Foundation.
$Id$
=head1 NAME
@@ -164,7 +164,7 @@
*/
-PARROT_MALLOC
+PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
IntList *
intlist_clone(PARROT_INTERP, ARGIN(const IntList *list))
@@ -182,7 +182,7 @@
*/
-PARROT_MALLOC
+PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
IntList *
intlist_new(PARROT_INTERP)
Modified: branches/tcif/src/library.c
==============================================================================
--- branches/tcif/src/library.c (original)
+++ branches/tcif/src/library.c Thu Feb 14 16:52:34 2008
@@ -623,7 +623,7 @@
return string_to_cstring(interp, s);
}
else
- return str_dup( "." );
+ return str_dup(".");
}
}
Modified: branches/tcif/src/list.c
==============================================================================
--- branches/tcif/src/list.c (original)
+++ branches/tcif/src/list.c Thu Feb 14 16:52:34 2008
@@ -208,8 +208,8 @@
__attribute__nonnull__(2)
FUNC_MODIFIES(*list);
-PARROT_MALLOC
PARROT_CANNOT_RETURN_NULL
+PARROT_WARN_UNUSED_RESULT
static List_chunk * allocate_chunk(PARROT_INTERP,
ARGIN(List *list),
UINTVAL items,
@@ -311,8 +311,8 @@
*/
-PARROT_MALLOC
PARROT_CANNOT_RETURN_NULL
+PARROT_WARN_UNUSED_RESULT
static List_chunk *
allocate_chunk(PARROT_INTERP, ARGIN(List *list), UINTVAL items, UINTVAL size)
{
@@ -1234,7 +1234,7 @@
*/
PARROT_API
-PARROT_MALLOC
+PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
List *
list_new(PARROT_INTERP, PARROT_DATA_TYPE type)
@@ -1422,7 +1422,7 @@
*/
PARROT_API
-PARROT_MALLOC
+PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
List *
list_clone(PARROT_INTERP, ARGIN(const List *other))
Modified: branches/tcif/src/ops/string.ops
==============================================================================
--- branches/tcif/src/ops/string.ops (original)
+++ branches/tcif/src/ops/string.ops Thu Feb 14 16:52:34 2008
@@ -39,13 +39,13 @@
=cut
inline op ord(out INT, in STR) :base_core {
- $1 = string_ord(interp, $2, 0);
- goto NEXT();
+ $1 = string_ord(interp, $2, 0);
+ goto NEXT();
}
inline op ord(out INT, in STR, in INT) :base_core {
- $1 = string_ord(interp, $2, $3);
- goto NEXT();
+ $1 = string_ord(interp, $2, $3);
+ goto NEXT();
}
@@ -57,10 +57,9 @@
=cut
inline op chr(out STR, in INT) :base_core {
- STRING *s;
- s = string_chr(interp, (UINTVAL)$2);
- $1 = s;
- goto NEXT();
+ STRING * const s = string_chr(interp, (UINTVAL)$2);
+ $1 = s;
+ goto NEXT();
}
@@ -78,13 +77,13 @@
=cut
inline op chopn(inout STR, in INT) :base_core {
- string_chopn_inplace(interp, $1, $2);
- goto NEXT();
+ string_chopn_inplace(interp, $1, $2);
+ goto NEXT();
}
inline op chopn(out STR, in STR, in INT) :base_core {
- $1 = string_chopn(interp, $2, $3);
- goto NEXT();
+ $1 = string_chopn(interp, $2, $3);
+ goto NEXT();
}
@@ -115,13 +114,13 @@
=cut
inline op concat(inout STR, in STR) :base_mem {
- $1 = string_append(interp, $1, $2);
- goto NEXT();
+ $1 = string_append(interp, $1, $2);
+ goto NEXT();
}
inline op concat(out STR, in STR, in STR) :base_mem {
- $1 = string_concat(interp, $2, $3, 1);
- goto NEXT();
+ $1 = string_concat(interp, $2, $3, 1);
+ goto NEXT();
}
@@ -141,11 +140,11 @@
=cut
inline op repeat(out STR, in STR, in INT) :base_mem {
- if ($3 < 0)
- real_exception(interp, NULL, NEG_REPEAT,
- "Cannot repeat with negative arg");
- $1 = string_repeat(interp, $2, (UINTVAL)$3, NULL);
- goto NEXT();
+ if ($3 < 0)
+ real_exception(interp, NULL, NEG_REPEAT,
+ "Cannot repeat with negative arg");
+ $1 = string_repeat(interp, $2, (UINTVAL)$3, NULL);
+ goto NEXT();
}
@@ -162,21 +161,21 @@
=cut
inline op length(out INT, in STR) :base_mem {
- $1 = $2 ? string_length(interp, $2) : 0;
- goto NEXT();
+ $1 = $2 ? string_length(interp, $2) : 0;
+ goto NEXT();
}
inline op bytelength(out INT, in STR) :base_mem {
- UINTVAL n;
- STRING * const s = $2;
- if (!s)
- n = 0;
- else {
- n = s->bufused;
- PARROT_ASSERT(n == ENCODING_BYTES(interp, $2));
- }
- $1 = n;
- goto NEXT();
+ UINTVAL n;
+ STRING * const s = $2;
+ if (!s)
+ n = 0;
+ else {
+ n = s->bufused;
+ PARROT_ASSERT(n == ENCODING_BYTES(interp, $2));
+ }
+ $1 = n;
+ goto NEXT();
}
@@ -191,8 +190,8 @@
=cut
op pin(inout STR) :base_mem {
- string_pin(interp, $1);
- goto NEXT();
+ string_pin(interp, $1);
+ goto NEXT();
}
@@ -204,8 +203,8 @@
=cut
op unpin(inout STR) :base_mem {
- string_unpin(interp, $1);
- goto NEXT();
+ string_unpin(interp, $1);
+ goto NEXT();
}
@@ -241,29 +240,29 @@
=cut
inline op substr(out STR, in STR, in INT) :base_core {
- const INTVAL len = string_length(interp, $2);
- $1 = string_substr(interp, $2, $3, len, &$1, 0);
- goto NEXT();
+ const INTVAL len = string_length(interp, $2);
+ $1 = string_substr(interp, $2, $3, len, &$1, 0);
+ goto NEXT();
}
inline op substr(out STR, in STR, in INT, in INT) :base_core {
- $1 = string_substr(interp, $2, $3, $4, &$1, 0);
- goto NEXT();
+ $1 = string_substr(interp, $2, $3, $4, &$1, 0);
+ goto NEXT();
}
inline op substr(out STR, inout STR, in INT, in INT, in STR) :base_core {
- $1 = string_replace(interp, $2, $3, $4, $5, &$1);
- goto NEXT();
+ $1 = string_replace(interp, $2, $3, $4, $5, &$1);
+ goto NEXT();
}
inline op substr(inout STR, in INT, in INT, in STR) :base_core {
- (void)string_replace(interp, $1, $2, $3, $4, NULL);
- goto NEXT();
+ (void)string_replace(interp, $1, $2, $3, $4, NULL);
+ goto NEXT();
}
inline op substr(out STR, invar PMC, in INT, in INT) :base_core {
- $1 = $2->vtable->substr_str(interp, $2, $3, $4);
- goto NEXT();
+ $1 = $2->vtable->substr_str(interp, $2, $3, $4);
+ goto NEXT();
}
@@ -337,8 +336,8 @@
}
inline op new(out STR, in INT) :base_mem {
- $1 = string_make_empty(interp, enum_stringrep_one, $2);
- goto NEXT();
+ $1 = string_make_empty(interp, enum_stringrep_one, $2);
+ goto NEXT();
}
@@ -425,13 +424,13 @@
=cut
inline op upcase(out STR, in STR) :base_core {
- $1 = string_upcase(interp, $2);
- goto NEXT();
+ $1 = string_upcase(interp, $2);
+ goto NEXT();
}
inline op upcase(inout STR) :base_core {
- string_upcase_inplace(interp, $1);
- goto NEXT();
+ string_upcase_inplace(interp, $1);
+ goto NEXT();
}
@@ -446,13 +445,13 @@
=cut
inline op downcase(out STR, in STR) :base_core {
- $1 = string_downcase(interp, $2);
- goto NEXT();
+ $1 = string_downcase(interp, $2);
+ goto NEXT();
}
inline op downcase(inout STR) :base_core {
- string_downcase_inplace(interp, $1);
- goto NEXT();
+ string_downcase_inplace(interp, $1);
+ goto NEXT();
}
@@ -467,13 +466,13 @@
=cut
inline op titlecase(out STR, in STR) :base_core {
- $1 = string_titlecase(interp, $2);
- goto NEXT();
+ $1 = string_titlecase(interp, $2);
+ goto NEXT();
}
inline op titlecase(inout STR) :base_core {
- string_titlecase_inplace(interp, $1);
- goto NEXT();
+ string_titlecase_inplace(interp, $1);
+ goto NEXT();
}
@@ -532,34 +531,34 @@
=cut
op charset(out INT, in STR) :base_core {
- $1 = Parrot_charset_number_of_str(interp, $2);
- goto NEXT();
+ $1 = Parrot_charset_number_of_str(interp, $2);
+ goto NEXT();
}
op charsetname(out STR, in INT) :base_core {
- STRING * const name = Parrot_charset_name(interp, $2);
- $1 = name ? string_copy(interp, name) : NULL;
- goto NEXT();
+ STRING * const name = Parrot_charset_name(interp, $2);
+ $1 = name ? string_copy(interp, name) : NULL;
+ goto NEXT();
}
op find_charset(out INT, in STR) :base_core {
- INTVAL n = Parrot_charset_number(interp, $2);
- if (n < 0)
- real_exception(interp, NULL, 1,
- "charset '%Ss' not found", $2);
- $1 = n;
- goto NEXT();
+ const INTVAL n = Parrot_charset_number(interp, $2);
+ if (n < 0)
+ real_exception(interp, NULL, 1,
+ "charset '%Ss' not found", $2);
+ $1 = n;
+ goto NEXT();
}
op trans_charset(inout STR, in INT) {
- $1 = Parrot_string_trans_charset(interp, $1, $2, NULL);
- goto NEXT();
+ $1 = Parrot_string_trans_charset(interp, $1, $2, NULL);
+ goto NEXT();
}
op trans_charset(out STR, in STR, in INT) {
- STRING *dest = new_string_header(interp, 0);
- $1 = Parrot_string_trans_charset(interp, $2, $3, dest);
- goto NEXT();
+ STRING *dest = new_string_header(interp, 0);
+ $1 = Parrot_string_trans_charset(interp, $2, $3, dest);
+ goto NEXT();
}
@@ -595,29 +594,29 @@
}
op encodingname(out STR, in INT) :base_core {
- STRING * const name = Parrot_encoding_name(interp, $2);
- $1 = name ? string_copy(interp, name) : NULL;
- goto NEXT();
+ STRING * const name = Parrot_encoding_name(interp, $2);
+ $1 = name ? string_copy(interp, name) : NULL;
+ goto NEXT();
}
op find_encoding(out INT, in STR) :base_core {
- INTVAL n = Parrot_encoding_number(interp, $2);
- if (n < 0)
- real_exception(interp, NULL, 1,
- "encoding '%Ss' not found", $2);
- $1 = n;
- goto NEXT();
+ const INTVAL n = Parrot_encoding_number(interp, $2);
+ if (n < 0)
+ real_exception(interp, NULL, 1,
+ "encoding '%Ss' not found", $2);
+ $1 = n;
+ goto NEXT();
}
op trans_encoding(inout STR, in INT) {
- $1 = Parrot_string_trans_encoding(interp, $1, $2, NULL);
- goto NEXT();
+ $1 = Parrot_string_trans_encoding(interp, $1, $2, NULL);
+ goto NEXT();
}
op trans_encoding(out STR, in STR, in INT) {
- STRING *dest = new_string_header(interp, 0);
- $1 = Parrot_string_trans_encoding(interp, $2, $3, dest);
- goto NEXT();
+ STRING * const dest = new_string_header(interp, 0);
+ $1 = Parrot_string_trans_encoding(interp, $2, $3, dest);
+ goto NEXT();
}
@@ -629,8 +628,8 @@
=cut
inline op is_cclass(out INT, in INT, in STR, in INT) {
- $1 = Parrot_string_is_cclass(interp, $2, $3, $4);
- goto NEXT();
+ $1 = Parrot_string_is_cclass(interp, $2, $3, $4);
+ goto NEXT();
}
@@ -644,8 +643,8 @@
=cut
inline op find_cclass(out INT, in INT, in STR, in INT, in INT) {
- $1 = Parrot_string_find_cclass(interp, $2, $3, $4, $5);
- goto NEXT();
+ $1 = Parrot_string_find_cclass(interp, $2, $3, $4, $5);
+ goto NEXT();
}
@@ -659,8 +658,8 @@
=cut
inline op find_not_cclass(out INT, in INT, in STR, in INT, in INT) {
-$1 = Parrot_string_find_not_cclass(interp, $2, $3, $4, $5);
- goto NEXT();
+ $1 = Parrot_string_find_not_cclass(interp, $2, $3, $4, $5);
+ goto NEXT();
}
@@ -676,13 +675,13 @@
=cut
op escape(out STR, invar STR) {
- $1 = string_escape_string(interp, $2);
- goto NEXT();
+ $1 = string_escape_string(interp, $2);
+ goto NEXT();
}
op compose(out STR, in STR) {
- $1 = string_compose(interp, $2);
- goto NEXT();
+ $1 = string_compose(interp, $2);
+ goto NEXT();
}
@@ -690,7 +689,7 @@
=head1 COPYRIGHT
-Copyright (C) 2001-2007, The Perl Foundation.
+Copyright (C) 2001-2008, The Perl Foundation.
=head1 LICENSE
Modified: branches/tcif/src/pmc.c
==============================================================================
--- branches/tcif/src/pmc.c (original)
+++ branches/tcif/src/pmc.c Thu Feb 14 16:52:34 2008
@@ -57,7 +57,7 @@
PARROT_API
PARROT_CANNOT_RETURN_NULL
-PARROT_MALLOC
+PARROT_WARN_UNUSED_RESULT
PMC *
pmc_new(PARROT_INTERP, INTVAL base_type)
{
Modified: branches/tcif/src/pmc/class.pmc
==============================================================================
--- branches/tcif/src/pmc/class.pmc (original)
+++ branches/tcif/src/pmc/class.pmc Thu Feb 14 16:52:34 2008
@@ -187,7 +187,7 @@
name_arg = Parrot_NameSpace_nci_get_name(interp, new_namespace);
}
else {
- PMC *hll_ns = VTABLE_get_pmc_keyed_int(interp,
+ PMC * const hll_ns = VTABLE_get_pmc_keyed_int(interp,
interp->HLL_namespace, CONTEXT(interp->ctx)->current_HLL);
new_namespace = Parrot_make_namespace_keyed(interp, hll_ns,
name_arg);
}
@@ -761,7 +761,9 @@
Parrot_Class * const _class = PARROT_CLASS(SELF);
/* Do the composition. */
- Parrot_ComposeRole(interp, role, PMCNULL, 0, PMCNULL, 0,
+ Parrot_ComposeRole(interp, role,
+ _class->resolve_method,
!PMC_IS_NULL(_class->resolve_method),
+ PMCNULL, 0,
_class->methods, _class->roles);
}
@@ -1420,13 +1422,12 @@
*/
PCCMETHOD new(PMC *args :slurpy :named) {
- PMC *obj;
/* Check if any arguments are in the slurpy hash, don't pass an empty
* hash to instantiate */
- if (VTABLE_elements(interp, args) > 0)
- obj = VTABLE_instantiate(interp, SELF, args);
- else
- obj = VTABLE_instantiate(interp, SELF, PMCNULL);
+ PMC * const obj =
+ VTABLE_elements(interp, args) > 0
+ ? VTABLE_instantiate(interp, SELF, args)
+ : VTABLE_instantiate(interp, SELF, PMCNULL);
PCCRETURN(PMC *obj);
}
@@ -1442,8 +1443,8 @@
*/
PCCMETHOD attributes() {
- STRING * const attr_str = CONST_STRING(interp, "attributes");
- PMC * const ret_attrib_metadata = DYNSELF.inspect_str(attr_str);
+ STRING * const attr_str = CONST_STRING(interp,
"attributes");
+ PMC * const ret_attrib_metadata = DYNSELF.inspect_str(attr_str);
PCCRETURN(PMC *ret_attrib_metadata);
}
@@ -1516,10 +1517,10 @@
PCCMETHOD find_method(STRING *name) {
Parrot_Class * const _class = PARROT_CLASS(SELF);
- int num_classes, i;
+ int i;
/* Walk and search. One day, we'll use the cache first. */
- num_classes = VTABLE_elements(interp, _class->all_parents);
+ const int num_classes = VTABLE_elements(interp, _class->all_parents);
for (i = 0; i < num_classes; i++) {
/* Get the class and see if it has the method. */
Modified: branches/tcif/src/string.c
==============================================================================
--- branches/tcif/src/string.c (original)
+++ branches/tcif/src/string.c Thu Feb 14 16:52:34 2008
@@ -436,6 +436,59 @@
/*
+=item C<STRING * string_concat>
+
+Concatenates two Parrot strings. If necessary, converts the second
+string's encoding and/or type to match those of the first string. If
+either string is C<NULL>, then a copy of the non-C<NULL> string is
+returned. If both strings are C<NULL>, then a new zero-length string is
+created and returned.
+
+=cut
+
+*/
+
+PARROT_API
+PARROT_CANNOT_RETURN_NULL
+STRING *
+string_concat(PARROT_INTERP, ARGIN_NULLOK(STRING *a),
+ ARGIN_NULLOK(STRING *b), UINTVAL Uflags)
+{
+ if (a != NULL && a->strlen != 0) {
+ if (b != NULL && b->strlen != 0) {
+ const CHARSET *cs;
+ const ENCODING *enc;
+ STRING *result;
+
+ cs = string_rep_compatible(interp, a, b, &enc);
+ if (!cs) {
+ cs = a->charset;
+ enc = a->encoding;
+ }
+ result =
+ string_make_direct(interp, NULL,
+ a->bufused + b->bufused,
+ enc, cs, 0);
+
+ result = string_append(interp, result, a);
+ result = string_append(interp, result, b);
+
+ return result;
+ }
+ else {
+ return string_copy(interp, a);
+ }
+ }
+ else {
+ return b
+ ? string_copy(interp, b)
+ : string_make(interp, NULL, 0, NULL, Uflags);
+ }
+}
+
+
+/*
+
=item C<STRING * string_append>
Take in two Parrot strings and append the second to the first.
@@ -957,58 +1010,6 @@
/*
-=item C<STRING * string_concat>
-
-Concatenates two Parrot strings. If necessary, converts the second
-string's encoding and/or type to match those of the first string. If
-either string is C<NULL>, then a copy of the non-C<NULL> string is
-returned. If both strings are C<NULL>, then a new zero-length string is
-created and returned.
-
-=cut
-
-*/
-
-PARROT_API
-PARROT_CANNOT_RETURN_NULL
-STRING *
-string_concat(PARROT_INTERP, ARGIN_NULLOK(STRING *a),
- ARGIN_NULLOK(STRING *b), UINTVAL Uflags)
-{
- if (a != NULL && a->strlen != 0) {
- if (b != NULL && b->strlen != 0) {
- const CHARSET *cs;
- const ENCODING *enc;
- STRING *result;
-
- cs = string_rep_compatible(interp, a, b, &enc);
- if (!cs) {
- cs = a->charset;
- enc = a->encoding;
- }
- result =
- string_make_direct(interp, NULL,
- a->bufused + b->bufused,
- enc, cs, 0);
-
- result = string_append(interp, result, a);
- result = string_append(interp, result, b);
-
- return result;
- }
- else {
- return string_copy(interp, a);
- }
- }
- else {
- return b
- ? string_copy(interp, b)
- : string_make(interp, NULL, 0, NULL, Uflags);
- }
-}
-
-/*
-
=item C<STRING * string_repeat>
Repeats the specified Parrot string I<num> times and stores the result
Modified: branches/tcif/t/codingstd/linelength.t
==============================================================================
--- branches/tcif/t/codingstd/linelength.t (original)
+++ branches/tcif/t/codingstd/linelength.t Thu Feb 14 16:52:34 2008
@@ -129,8 +129,6 @@
__DATA__
# Lex and Bison generated
-compilers/ast/astlexer.c
-compilers/ast/astparser.c
compilers/imcc/imclexer.c
compilers/imcc/imcparser.c
compilers/pirc/new/main.c
@@ -151,15 +149,5 @@
languages/plumhead/src/yacc/plumhead_lexer.c
languages/plumhead/src/yacc/plumhead_parser.c
languages/plumhead/src/yacc/plumhead_parser.h
-# Generators with big strings
-tools/build/jit2c.pl
-tools/build/nativecall.pl
-tools/dev/lib_deps.pl
-tools/dev/mk_inno.pl
-tools/dev/parrot_coverage.pl
-# these ones include a big URL
-cage/todo.pod
-docs/dev/pmc_obj_design_meeting_notes.pod
-docs/gettingstarted.pod
-docs/glossary.pod
-languages/LANGUAGES_STATUS.pod
+# these ones include long POD
+docs/embed.pod
Modified: branches/tcif/t/harness
==============================================================================
--- branches/tcif/t/harness (original)
+++ branches/tcif/t/harness Thu Feb 14 16:52:34 2008
@@ -2,6 +2,64 @@
# Copyright (C) 2001-2007, The Perl Foundation.
# $Id$
+
+use strict;
+use warnings;
+use Getopt::Std;
+use Test::Harness();
+use lib qw( lib );
+use Parrot::Harness::DefaultTests;
+use Parrot::Harness::Options qw(
+ handle_long_options
+ get_test_prog_args
+ Usage
+);
+use Parrot::Harness::Smoke qw(
+ generate_html_smoke_report
+);
+
+local @ARGV = @ARGV;
+my $longopts;
+($longopts, @ARGV) = handle_long_options(@ARGV);
+
+$ENV{RUNNING_MAKE_TEST} = $longopts->{running_make_test};
+
+# Suck the short options into the TEST_PROG_ARGS
+# environmental variable.
+my %opts;
+getopts('wgjPCSefbvdr?hO:D:', \%opts);
+
+if ($opts{'?'} || $opts{h} || $longopts->{help}) {
+ Usage();
+ exit;
+}
+
+# add -D40; merge it with any existing -D argument
+$opts{D} = sprintf( '%x', hex(40) | (exists $opts{D} ? hex($opts{D}) : 0));
+
+my $args = get_test_prog_args(
+ \%opts, $longopts->{gc_debug}, $longopts->{run_exec});
+$ENV{TEST_PROG_ARGS} = $args;
+
+# now build the list of tests to run, either from the command
+# line or from @default tests
+my @default_tests = get_default_tests(
+ $longopts->{core_tests_only},
+ $longopts->{runcore_tests_only}
+);
+
+my @tests = map { glob( $_ ) } (@ARGV ? @ARGV : @default_tests);
+
+if (!$longopts->{html}) {
+ Test::Harness::runtests(@tests);
+} else {
+ generate_html_smoke_report ( {
+ tests => \@tests,
+ args => $args,
+ file => 'smoke.html',
+ } );
+}
+
=head1 NAME
t/harness - Parrot Test Harness
@@ -82,218 +140,6 @@
=back
-=cut
-
-
-use strict;
-use warnings;
-use lib qw( . lib ../lib ../../lib );
-
-use Getopt::Std;
-use Test::Harness();
-use Parrot::Config qw/%PConfig/;
-use FindBin qw/$Bin/;
-
-# handle the long options
-
-$ENV{RUNNING_MAKE_TEST} = grep { $_ eq '--running-make-test' } @ARGV;
-@ARGV = grep { $_ ne '--running-make-test' } @ARGV;
-
-my $gc_debug = grep { $_ eq '--gc-debug' } @ARGV;
-@ARGV = grep { $_ ne '--gc-debug' } @ARGV;
-
-my $core_tests_only = grep { $_ eq '--core-tests' } @ARGV;
-@ARGV = grep { $_ ne '--core-tests' } @ARGV;
-
-my $runcore_tests_only = grep { $_ eq '--runcore-tests' } @ARGV;
-@ARGV = grep { $_ ne '--runcore-tests' } @ARGV;
-
-my $html = grep { $_ eq '--html' } @ARGV;
-@ARGV = grep { $_ ne '--html' } @ARGV;
-
-my $run_exec = grep { $_ eq '--run-exec' } @ARGV;
-@ARGV = grep { $_ ne '--run-exec' } @ARGV;
-
-# Suck the short options into the TEST_PROG_ARGS evar:
-my %opts;
-getopts('wgjPCSefbvdr?hO:D:', \%opts);
-if ($opts{'?'} || $opts{h}) {
- print <<"EOF";
-perl t/harness [options] [testfiles]
- -w ... warnings on
- -g ... run CGoto
- -j ... run JIT
- -C ... run CGP
- -S ... run Switched
- -b ... run bounds checked
- --run-exec ... run exec core
- -f ... run fast core
- -v ... run verbose
- -d ... run debug
- -r ... assemble to PBC run PBC
- -O[012] ... optimize
- -D[number] ... pass debug flags to parrot interpreter
- --running-make-test
- --gc-debug
- --core-tests
- --runcore-tests
- --html
-EOF
- exit;
-}
-
-# add -D40; merge it with any existing -D argument
-$opts{D} = sprintf( '%x', hex(40) | (exists $opts{D} ? hex($opts{D}) : 0));
-
-my $args = join(' ', map { "-$_" } keys %opts );
-$args =~ s/-O/-O$opts{O}/ if exists $opts{O};
-$args =~ s/-D/-D$opts{D}/;
-$args .= ' --gc-debug' if $gc_debug;
-# XXX find better way for passing run_exec to Parrot::Test
-$args .= ' --run-exec' if $run_exec;
-$ENV{TEST_PROG_ARGS} = $args;
-
-# Build the lists of tests to be run
-
-# runcore tests are always run.
-my @runcore_tests = qw(
- t/compilers/imcc/*/*.t
- t/op/*.t
- t/pmc/*.t
- t/oo/*.t
- t/native_pbc/*.t
- t/dynpmc/*.t
- t/dynoplibs/*.t
- t/compilers/pge/*.t
- t/compilers/pge/p5regex/*.t
- t/compilers/pge/perl6regex/*.t
- t/compilers/tge/*.t
- t/library/*.t
-);
-
-# core tests are run unless --runcore-tests is present. Typically
-# this list and the list above are run in response to --core-tests
-my @core_tests = qw(
- t/run/*.t
- t/src/*.t
- t/tools/*.t
- t/perl/*.t
- t/stm/*.t
-);
-
-# configure tests are tests to be run at the beginning of 'make test';
-# standard tests are other tests run by default with no core options
-# present
-my @standard_tests = qw(
- t/compilers/json/*.t
- t/examples/*.t
- t/doc/*.t
- t/distro/manifest.t
-);
-
-# add metadata.t and coding standards tests only if we're DEVELOPING
-if ( -e "$Bin/../DEVELOPING" ) {
- push @standard_tests, map { "t/codingstd/$_" } qw(
- c_code_coda.t
- c_header_guards.t
- c_indent.t
- c_struct.t
- check_toxxx.t
- copyright.t
- c_cppcomments.t
- c_cuddled_else.t
- filenames.t
- gmt_utc.t
- linelength.t
- pccmethod_deps.t
- pir_code_coda.t
- svn_id.t
- tabs.t
- trailing_space.t
- );
- # XXX: This takes WAY too long to run: perlcritic.t
-}
-
-# build the list of default tests
-my @default_tests = @runcore_tests;
-unless ($runcore_tests_only) {
- push @default_tests, @core_tests;
- unless ($core_tests_only) {
- push @default_tests, @standard_tests;
- }
-}
-
-# now build the list of tests to run, either from the command
-# line or from @default tests
-my @tests = map { glob( $_ ) } (@ARGV ? @ARGV : @default_tests);
-
-if (!$html) {
- Test::Harness::runtests(@tests);
-} else {
- my @smoke_config_vars = qw(
- osname archname cc build_dir cpuarch revision VERSION optimize DEVEL
- );
-
- eval {
- require Test::TAP::HTMLMatrix;
- require Test::TAP::Model::Visual;
- };
- die "You must have Test::TAP::HTMLMatrix installed.\n\n$@"
- if $@;
-
- {
- no warnings qw/redefine once/;
- *Test::TAP::Model::run_tests = sub {
- my $self = shift;
-
- $self->_init;
- $self->{meat}{start_time} = time;
-
- my %stats;
-
- foreach my $file (@_) {
- my $data;
- print STDERR "- $file\n";
- $data = $self->run_test($file);
- $stats{tests} += $data->{results}{max} || 0;
- $stats{ok} += $data->{results}{ok} || 0;
- }
-
- printf STDERR "%s OK from %s tests (%.2f%% ok)\n\n",
- $stats{ok},
- $stats{tests},
- $stats{ok} / $stats{tests} * 100;
-
- $self->{meat}{end_time} = time;
- };
-
- my $start = time();
- my $model = Test::TAP::Model::Visual->new();
- $model->run_tests(@tests);
-
- my $end = time();
-
- my $duration = $end - $start;
-
- my $v = Test::TAP::HTMLMatrix->new(
- $model,
- join("\n",
- "duration: $duration",
- "branch: unknown",
- "harness_args: " . (($args) ? $args : "N/A"),
- map { "$_: $PConfig{$_}" } sort @smoke_config_vars),
- );
-
- $v->has_inline_css(1); # no separate css file
-
- open HTML, ">", "smoke.html";
- print HTML $v->html;
- close HTML;
-
- print "smoke.html has been generated.\n";
- }
-}
-
=head1 HISTORY
Mike Lambert stole F<t/harness> for F<languages/perl6/t/harness>.
Modified: branches/tcif/tools/build/headerizer.pl
==============================================================================
--- branches/tcif/tools/build/headerizer.pl (original)
+++ branches/tcif/tools/build/headerizer.pl Thu Feb 14 16:52:34 2008
@@ -44,9 +44,9 @@
=over 4
-=item C<--apilist>
+=item C<--macro=X>
-Print a list of PARROT_API functions instead of updating source.
+Print a list of all functions that have macro X. For example,
--macro=PARROT_API.
=back
@@ -406,11 +406,12 @@
}
sub main {
- my $apilist;
+ my $macro_match;
GetOptions(
- apilist => \$apilist,
+ 'macro=s' => \$macro_match,
) or exit(1);
+ die "No files specified.\n" unless @ARGV;
my %ofiles;
++$ofiles{$_} for @ARGV;
my @ofiles = sort keys %ofiles;
@@ -442,7 +443,7 @@
}
my @decls;
- if ( $apilist || -f $pmcfile ) {
+ if ( $macro_match || -f $pmcfile ) {
@decls = extract_function_declarations( $csource );
}
else {
@@ -453,11 +454,15 @@
my $components = function_components_from_declaration( $cfile,
$decl );
push( @{ $cfiles{$hfile}->{$cfile} }, $components ) unless $hfile
eq 'none';
push( @{ $cfiles_with_statics{$cfile} }, $components ) if
$components->{is_static};
- push( @{ $api{$cfile} }, $components ) if $components->{is_api};
+ if ( $macro_match ) {
+ if ( grep { $_ eq $macro_match } @{$components->{macros}} ) {
+ push( @{ $api{$cfile} }, $components );
+ }
+ }
}
} # for @cfiles
- if ( $apilist ) {
+ if ( $macro_match ) {
my $nfuncs = 0;
for my $cfile ( sort keys %api ) {
my @funcs = sort { $a->{name} cmp $b->{name} } @{$api{$cfile}};
@@ -467,7 +472,8 @@
++$nfuncs;
}
}
- print "$nfuncs PARROT_API functions\n";
+ my $s = $nfuncs == 1 ? '' : 's';
+ print "$nfuncs $macro_match function$s\n";
}
else { # Normal headerization and updating
# Update all the .h files
Modified: branches/tcif/tools/build/nativecall.pl
==============================================================================
--- branches/tcif/tools/build/nativecall.pl (original)
+++ branches/tcif/tools/build/nativecall.pl Thu Feb 14 16:52:34 2008
@@ -204,8 +204,6 @@
my ( $ret, $args ) = split m/\s+/, $_;
$args = '' if not defined $args;
- warn "Removed deprecated 'v' argument signature on line $. of $ARGV\n"
- if $args =~ s/^v$//;
die "Invalid return signature char '$ret' on line $. of $ARGV\n"
unless exists $ret_assign{$ret};
Modified: branches/tcif/tools/dev/pbc_to_exe_gen.pl
==============================================================================
--- branches/tcif/tools/dev/pbc_to_exe_gen.pl (original)
+++ branches/tcif/tools/dev/pbc_to_exe_gen.pl Thu Feb 14 16:52:34 2008
@@ -197,8 +197,6 @@
int main(int argc, const char *argv[])
{
PackFile *pf;
- STRING *executable_name;
- PMC *executable_name_pmc;
Parrot_Interp interp;
Parrot_set_config_hash();
|
|