[svn:parrot] r48748 - in branches/html_cleanup: . compilers/data_json compilers/imcc compilers/opsc compilers/opsc/src/Ops compilers/pct compilers/pge compilers/tge config/auto config/auto/llvm config/auto/sizes config/auto/zlib config/gen/makefiles docs/book/draft docs/book/pct docs/dev docs/pdds docs/project examples/embed examples/languages/abc examples/languages/squaak examples/pge examples/tools ext/nqp-rx include/parrot lib/Parrot lib/Parrot/Configure/Step lib/Parrot/Docs/Section ports/cygwin ports/debian runtime/parrot/languages runtime/parrot/library runtime/parrot/library/Math src src/call src/dynoplibs src/gc src/interp src/ops src/pmc src/runcore src/string t/codingstd t/compilers/tge t/dynoplibs t/examples t/oo t/op t/pmc t/run t/src t/steps/auto t/steps/init/hints t/tools tools/build tools/dev tools/release tools/util
mikehh at svn.parrot.org
mikehh at svn.parrot.org
Wed Sep 1 06:33:08 UTC 2010
Author: mikehh
Date: Wed Sep 1 06:33:06 2010
New Revision: 48748
URL: https://trac.parrot.org/parrot/changeset/48748
Log:
[html_cleanup] merge trunk into branch
Added:
branches/html_cleanup/config/auto/llvm/
- copied from r48747, trunk/config/auto/llvm/
branches/html_cleanup/config/auto/llvm.pm
- copied unchanged from r48747, trunk/config/auto/llvm.pm
branches/html_cleanup/examples/tools/pgegrep
- copied unchanged from r48747, trunk/examples/tools/pgegrep
branches/html_cleanup/t/examples/pgegrep.t
- copied unchanged from r48747, trunk/t/examples/pgegrep.t
branches/html_cleanup/t/steps/auto/llvm-01.t
- copied unchanged from r48747, trunk/t/steps/auto/llvm-01.t
branches/html_cleanup/tools/build/README
- copied unchanged from r48747, trunk/tools/build/README
branches/html_cleanup/tools/dev/README
- copied unchanged from r48747, trunk/tools/dev/README
branches/html_cleanup/tools/dev/addopstags.pl
- copied unchanged from r48747, trunk/tools/dev/addopstags.pl
branches/html_cleanup/tools/dev/dump_pbc.pl
- copied unchanged from r48747, trunk/tools/dev/dump_pbc.pl
branches/html_cleanup/tools/dev/headerizer.pl
- copied unchanged from r48747, trunk/tools/dev/headerizer.pl
branches/html_cleanup/tools/dev/ncidef2pasm.pl
- copied unchanged from r48747, trunk/tools/dev/ncidef2pasm.pl
branches/html_cleanup/tools/dev/parrot-config.pir
- copied unchanged from r48747, trunk/tools/dev/parrot-config.pir
branches/html_cleanup/tools/dev/perlcritic-cage.conf
- copied unchanged from r48747, trunk/tools/dev/perlcritic-cage.conf
branches/html_cleanup/tools/dev/perlcritic.conf
- copied unchanged from r48747, trunk/tools/dev/perlcritic.conf
branches/html_cleanup/tools/dev/perltidy.conf
- copied unchanged from r48747, trunk/tools/dev/perltidy.conf
branches/html_cleanup/tools/dev/update_copyright.pl
- copied unchanged from r48747, trunk/tools/dev/update_copyright.pl
branches/html_cleanup/tools/release/
- copied from r48747, trunk/tools/release/
Replaced:
branches/html_cleanup/config/auto/llvm/hello.c
- copied unchanged from r48747, trunk/config/auto/llvm/hello.c
branches/html_cleanup/tools/release/README
- copied unchanged from r48747, trunk/tools/release/README
branches/html_cleanup/tools/release/crow.pir
- copied unchanged from r48747, trunk/tools/release/crow.pir
branches/html_cleanup/tools/release/gen_release_info.pl
- copied unchanged from r48747, trunk/tools/release/gen_release_info.pl
branches/html_cleanup/tools/release/inc_ver.pir
- copied unchanged from r48747, trunk/tools/release/inc_ver.pir
branches/html_cleanup/tools/release/release.json
- copied unchanged from r48747, trunk/tools/release/release.json
branches/html_cleanup/tools/release/templates.json
- copied unchanged from r48747, trunk/tools/release/templates.json
Deleted:
branches/html_cleanup/t/tools/pgegrep.t
branches/html_cleanup/tools/build/addopstags.pl
branches/html_cleanup/tools/build/headerizer.pl
branches/html_cleanup/tools/util/
Modified:
branches/html_cleanup/ (props changed)
branches/html_cleanup/MANIFEST
branches/html_cleanup/compilers/data_json/Rules.mak (props changed)
branches/html_cleanup/compilers/imcc/Rules.in (props changed)
branches/html_cleanup/compilers/imcc/pbc.c
branches/html_cleanup/compilers/opsc/ops2c.nqp
branches/html_cleanup/compilers/opsc/src/Ops/File.pm
branches/html_cleanup/compilers/pct/Rules.mak (props changed)
branches/html_cleanup/compilers/pge/Rules.mak (props changed)
branches/html_cleanup/compilers/tge/Rules.mak (props changed)
branches/html_cleanup/config/auto/sizes/intval_maxmin_c.in (props changed)
branches/html_cleanup/config/auto/zlib/ (props changed)
branches/html_cleanup/config/gen/makefiles/root.in
branches/html_cleanup/docs/book/draft/README (props changed)
branches/html_cleanup/docs/book/draft/appa_glossary.pod (props changed)
branches/html_cleanup/docs/book/draft/appb_patch_submission.pod (props changed)
branches/html_cleanup/docs/book/draft/appc_command_line_options.pod (props changed)
branches/html_cleanup/docs/book/draft/appd_build_options.pod (props changed)
branches/html_cleanup/docs/book/draft/appe_source_code.pod (props changed)
branches/html_cleanup/docs/book/draft/ch01_introduction.pod (props changed)
branches/html_cleanup/docs/book/draft/ch02_getting_started.pod (props changed)
branches/html_cleanup/docs/book/draft/ch07_dynpmcs.pod (props changed)
branches/html_cleanup/docs/book/draft/ch08_dynops.pod (props changed)
branches/html_cleanup/docs/book/draft/ch10_opcode_reference.pod (props changed)
branches/html_cleanup/docs/book/draft/ch11_directive_reference.pod (props changed)
branches/html_cleanup/docs/book/draft/ch12_operator_reference.pod (props changed)
branches/html_cleanup/docs/book/draft/chXX_hlls.pod (props changed)
branches/html_cleanup/docs/book/draft/chXX_library.pod (props changed)
branches/html_cleanup/docs/book/draft/chXX_testing_and_debugging.pod (props changed)
branches/html_cleanup/docs/book/pct/ch01_introduction.pod (props changed)
branches/html_cleanup/docs/book/pct/ch02_getting_started.pod (props changed)
branches/html_cleanup/docs/book/pct/ch03_compiler_tools.pod (props changed)
branches/html_cleanup/docs/book/pct/ch04_pge.pod (props changed)
branches/html_cleanup/docs/book/pct/ch05_nqp.pod (props changed)
branches/html_cleanup/docs/dev/c_functions.pod (props changed)
branches/html_cleanup/docs/pdds/pdd30_install.pod (props changed)
branches/html_cleanup/docs/project/release_manager_guide.pod
branches/html_cleanup/examples/embed/cotorra.c (props changed)
branches/html_cleanup/examples/languages/abc/ (props changed)
branches/html_cleanup/examples/languages/squaak/ (props changed)
branches/html_cleanup/examples/pge/demo.pir (props changed)
branches/html_cleanup/ext/nqp-rx/Rules.mak (props changed)
branches/html_cleanup/include/parrot/call.h (props changed)
branches/html_cleanup/include/parrot/gc_api.h (props changed)
branches/html_cleanup/include/parrot/hash.h
branches/html_cleanup/include/parrot/runcore_api.h (props changed)
branches/html_cleanup/include/parrot/runcore_profiling.h (props changed)
branches/html_cleanup/include/parrot/runcore_trace.h (props changed)
branches/html_cleanup/include/parrot/scheduler_private.h
branches/html_cleanup/lib/Parrot/Configure/Step/List.pm
branches/html_cleanup/lib/Parrot/Configure/Step/Test.pm (props changed)
branches/html_cleanup/lib/Parrot/Docs/Section/Tools.pm
branches/html_cleanup/lib/Parrot/H2inc.pm (props changed)
branches/html_cleanup/ports/cygwin/parrot-1.0.0-1.cygport (props changed)
branches/html_cleanup/ports/debian/libparrot-dev.install.in (props changed)
branches/html_cleanup/ports/debian/libparrot.install.in (props changed)
branches/html_cleanup/ports/debian/parrot-doc.install.in (props changed)
branches/html_cleanup/ports/debian/parrot.install.in (props changed)
branches/html_cleanup/ports/debian/rules
branches/html_cleanup/runtime/parrot/languages/ (props changed)
branches/html_cleanup/runtime/parrot/library/Math/Rand.pir (props changed)
branches/html_cleanup/runtime/parrot/library/Rules.mak (props changed)
branches/html_cleanup/src/call/ops.c (props changed)
branches/html_cleanup/src/call/pcc.c (props changed)
branches/html_cleanup/src/dynext.c
branches/html_cleanup/src/dynoplibs/math.ops
branches/html_cleanup/src/gc/alloc_memory.c (props changed)
branches/html_cleanup/src/gc/alloc_resources.c (props changed)
branches/html_cleanup/src/gc/api.c (props changed)
branches/html_cleanup/src/gc/gc_ms.c
branches/html_cleanup/src/gc/malloc.c (props changed)
branches/html_cleanup/src/gc/malloc_trace.c (props changed)
branches/html_cleanup/src/gc/mark_sweep.c (props changed)
branches/html_cleanup/src/gc/system.c (props changed)
branches/html_cleanup/src/hash.c
branches/html_cleanup/src/interp/inter_cb.c (props changed)
branches/html_cleanup/src/interp/inter_create.c (props changed)
branches/html_cleanup/src/interp/inter_misc.c (props changed)
branches/html_cleanup/src/multidispatch.c
branches/html_cleanup/src/oo.c
branches/html_cleanup/src/ops/core_ops.c
branches/html_cleanup/src/ops/var.ops
branches/html_cleanup/src/packfile.c
branches/html_cleanup/src/pbc_merge.c
branches/html_cleanup/src/pmc/addrregistry.pmc
branches/html_cleanup/src/pmc/bigint.pmc
branches/html_cleanup/src/pmc/callcontext.pmc
branches/html_cleanup/src/pmc/class.pmc
branches/html_cleanup/src/pmc/exception.pmc
branches/html_cleanup/src/pmc/hash.pmc
branches/html_cleanup/src/pmc/imageiostrings.pmc
branches/html_cleanup/src/pmc/integer.pmc
branches/html_cleanup/src/pmc/multisub.pmc
branches/html_cleanup/src/pmc/namespace.pmc
branches/html_cleanup/src/pmc/parrotlibrary.pmc
branches/html_cleanup/src/runcore/cores.c (props changed)
branches/html_cleanup/src/runcore/main.c (contents, props changed)
branches/html_cleanup/src/runcore/profiling.c (props changed)
branches/html_cleanup/src/runcore/trace.c (props changed)
branches/html_cleanup/src/scheduler.c
branches/html_cleanup/src/string/api.c
branches/html_cleanup/t/codingstd/c_operator.t
branches/html_cleanup/t/codingstd/c_todo.t
branches/html_cleanup/t/codingstd/perlcritic.t
branches/html_cleanup/t/codingstd/pmc_docs.t (props changed)
branches/html_cleanup/t/compilers/tge/NoneGrammar.tg (props changed)
branches/html_cleanup/t/dynoplibs/debug.t
branches/html_cleanup/t/oo/isa.t
branches/html_cleanup/t/oo/objects.t (props changed)
branches/html_cleanup/t/oo/root_new.t (props changed)
branches/html_cleanup/t/op/gc-leaky-box.t
branches/html_cleanup/t/op/gc-leaky-call.t
branches/html_cleanup/t/op/lexicals.t
branches/html_cleanup/t/pmc/exception.t
branches/html_cleanup/t/pmc/hash.t
branches/html_cleanup/t/pmc/namespace-old.t (props changed)
branches/html_cleanup/t/pmc/stringiterator.t
branches/html_cleanup/t/pmc/timer.t
branches/html_cleanup/t/run/options.t
branches/html_cleanup/t/src/embed.t (props changed)
branches/html_cleanup/t/src/extend.t
branches/html_cleanup/t/steps/init/hints/linux-01.t (props changed)
branches/html_cleanup/t/tools/dump_pbc.t
branches/html_cleanup/tools/build/h2inc.pl (props changed)
branches/html_cleanup/tools/dev/fetch_languages.pl (props changed)
branches/html_cleanup/tools/dev/mk_gitignore.pl (props changed)
Modified: branches/html_cleanup/MANIFEST
==============================================================================
--- branches/html_cleanup/MANIFEST Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/MANIFEST Wed Sep 1 06:33:06 2010 (r48748)
@@ -214,6 +214,8 @@
config/auto/isreg.pm []
config/auto/isreg/test_c.in []
config/auto/jit.pm []
+config/auto/llvm.pm []
+config/auto/llvm/hello.c []
config/auto/memalign.pm []
config/auto/memalign/test2_c.in []
config/auto/memalign/test_c.in []
@@ -831,6 +833,7 @@
examples/tge/branch/transform.pir [examples]
examples/tools/Makefile [examples]
examples/tools/pbc_checker.cpp [examples]
+examples/tools/pgegrep [examples]
examples/tutorial/00_README.pod [examples]
examples/tutorial/01_temp_var.pir [examples]
examples/tutorial/02_local_var.pir [examples]
@@ -1696,6 +1699,7 @@
t/examples/namespace.t [test]
t/examples/pasm.t [test]
t/examples/past.t [test]
+t/examples/pgegrep.t [test]
t/examples/pir.t [test]
t/examples/pod.t [test]
t/examples/shootout.t [test]
@@ -1998,6 +2002,7 @@
t/steps/auto/inline-01.t [test]
t/steps/auto/isreg-01.t [test]
t/steps/auto/jit-01.t [test]
+t/steps/auto/llvm-01.t [test]
t/steps/auto/memalign-01.t [test]
t/steps/auto/msvc-01.t [test]
t/steps/auto/neg_0-01.t [test]
@@ -2089,7 +2094,6 @@
t/tools/pbc_disassemble.t [test]
t/tools/pbc_dump.t [test]
t/tools/pbc_merge.t [test]
-t/tools/pgegrep.t [test]
t/tools/pmc2cutils/01-pmc2cutils.t [test]
t/tools/pmc2cutils/02-find_file.t [test]
t/tools/pmc2cutils/03-dump_vtable.t [test]
@@ -2098,11 +2102,10 @@
t/tools/pmc2cutils/08-pmc-pm.t [test]
t/tools/pmc2cutils/README []doc
t/tools/testdata [test]
-tools/build/addopstags.pl []
+tools/build/README []doc
tools/build/c2str.pl []
tools/build/fixup_gen_file.pl []
tools/build/h2inc.pl []
-tools/build/headerizer.pl []
tools/build/ops2c.pl [devel]
tools/build/parrot_config_c.pl []
tools/build/pbcversion_h.pl []
@@ -2110,18 +2113,22 @@
tools/build/vtable_extend.pl []
tools/build/vtable_h.pl []
tools/dev/.gdbinit []
+tools/dev/README []doc
+tools/dev/addopstags.pl []
tools/dev/as2c.pl []
tools/dev/bench_op.pir []
tools/dev/branch_status.pl []
tools/dev/checkdepend.pl []
tools/dev/create_language.pl [devel]
tools/dev/debian_docs.sh []
+tools/dev/dump_pbc.pl []
tools/dev/faces.pl []
tools/dev/fetch_languages.pl []
tools/dev/gen_charset_tables.pl []
tools/dev/gen_class.pl []
tools/dev/gen_makefile.pl [devel]
tools/dev/gen_valgrind_suppressions.pl []
+tools/dev/headerizer.pl []
tools/dev/install_dev_files.pl []
tools/dev/install_doc_files.pl []
tools/dev/install_files.pl []
@@ -2139,9 +2146,11 @@
tools/dev/mk_rpm_manifests.pl []
tools/dev/nci_test_gen.pl []
tools/dev/nci_thunk_gen.pir []
+tools/dev/ncidef2pasm.pl []
tools/dev/nm.pl []
tools/dev/nopaste.pl []
tools/dev/ops_not_tested.pl []
+tools/dev/parrot-config.pir []
tools/dev/parrot-fuzzer []
tools/dev/parrot.supp []
tools/dev/parrot_api.pl []
@@ -2150,6 +2159,9 @@
tools/dev/parrotbench.pl []
tools/dev/pbc_header.pl []
tools/dev/pbc_to_exe.pir [devel]
+tools/dev/perlcritic-cage.conf []
+tools/dev/perlcritic.conf []
+tools/dev/perltidy.conf []
tools/dev/pmcrenumber.pl []
tools/dev/pmctree.pl []
tools/dev/pprof2cg.pl [devel]
@@ -2157,6 +2169,7 @@
tools/dev/search-ops.pl []
tools/dev/svnclobber.pl []
tools/dev/symlink.pl []
+tools/dev/update_copyright.pl []
tools/dev/vgp []
tools/dev/vgp_darwin []
tools/dev/vms-patch []
@@ -2167,19 +2180,12 @@
tools/docs/ops_summary.pl []
tools/install/smoke.pl []
tools/install/smoke_languages.pl []
-tools/util/crow.pir []
-tools/util/dump_pbc.pl []
-tools/util/gen_release_info.pl []
-tools/util/inc_ver.pir []
-tools/util/ncidef2pasm.pl []
-tools/util/parrot-config.pir []
-tools/util/perlcritic-cage.conf []
-tools/util/perlcritic.conf []
-tools/util/perltidy.conf []
-tools/util/pgegrep []
-tools/util/release.json []
-tools/util/templates.json []
-tools/util/update_copyright.pl []
+tools/release/README []doc
+tools/release/crow.pir []
+tools/release/gen_release_info.pl []
+tools/release/inc_ver.pir []
+tools/release/release.json []
+tools/release/templates.json []
# Local variables:
# mode: text
# buffer-read-only: t
Modified: branches/html_cleanup/compilers/imcc/pbc.c
==============================================================================
--- branches/html_cleanup/compilers/imcc/pbc.c Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/compilers/imcc/pbc.c Wed Sep 1 06:33:06 2010 (r48748)
@@ -363,7 +363,7 @@
interp->code->const_table->string_hash =
Parrot_pmc_new_init_int(interp, enum_class_Hash, enum_type_INTVAL);
((Hash *)VTABLE_get_pointer(interp, interp->code->const_table->string_hash))->compare =
- (hash_comp_fn)STRING_compare_distinct_cs_enc;
+ (hash_comp_fn)hash_compare_string_distinct_enc;
interp->code->const_table->constants =
mem_gc_allocate_n_zeroed_typed(interp, newcount, PackFile_Constant);
@@ -739,11 +739,11 @@
/* op not yet mapped */
bc->op_count++;
bc->op_func_table =
- mem_gc_realloc_n_typed_zeroed(interp, bc->op_func_table, bc->op_count, bc->op_count,
+ mem_gc_realloc_n_typed_zeroed(interp, bc->op_func_table, bc->op_count, bc->op_count - 1,
op_func_t);
bc->op_func_table[bc->op_count - 1] = op_func;
bc->op_info_table =
- mem_gc_realloc_n_typed_zeroed(interp, bc->op_info_table, bc->op_count, bc->op_count,
+ mem_gc_realloc_n_typed_zeroed(interp, bc->op_info_table, bc->op_count, bc->op_count - 1,
op_info_t *);
bc->op_info_table[bc->op_count - 1] = info;
Modified: branches/html_cleanup/compilers/opsc/ops2c.nqp
==============================================================================
--- branches/html_cleanup/compilers/opsc/ops2c.nqp Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/compilers/opsc/ops2c.nqp Wed Sep 1 06:33:06 2010 (r48748)
@@ -75,7 +75,7 @@
-h --help print this usage information
-n --no-lines do not print #line directives in generated C code (line numbers are not currently supported)
-#debugging options:
+debugging options:
-g --debug perform all processing but do not write to any files
");
pir::exit(0);
Modified: branches/html_cleanup/compilers/opsc/src/Ops/File.pm
==============================================================================
--- branches/html_cleanup/compilers/opsc/src/Ops/File.pm Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/compilers/opsc/src/Ops/File.pm Wed Sep 1 06:33:06 2010 (r48748)
@@ -296,13 +296,37 @@
method _set_version() {
my $config := _config();
- my $version := $config<VERSION>;
+ my $version_filename;
+ if $config<installed> {
+ $version_filename :=
+ $config<libdir> ~
+ $config<versiondir> ~
+ $config<slash> ~
+ 'VERSION';
+ }
+ else {
+ $version_filename :=
+ $config<prefix> ~
+ $config<slash> ~
+ 'VERSION';
+ }
+
+ grammar VERSION {
+ rule TOP { <version> }
+ rule version { $<major>=(\d+) '.' $<minor>=(\d+) '.' $<patch>=(\d+) }
+ }
+
+ my $version := slurp($version_filename);
+ my $version_match := VERSION.parse($version);
#say("# $version");
- my @bits := split('.', $version);
- self<version_major> := @bits[0];
- self<version_minor> := @bits[1];
- self<version_patch> := @bits[2];
- self<version> := @bits;
+ self<version_major> := +$version_match<version><major>;
+ self<version_minor> := +$version_match<version><minor>;
+ self<version_patch> := +$version_match<version><patch>;
+ self<version> := [
+ +self<version_major>,
+ +self<version_minor>,
+ +self<version_match>,
+ ];
}
# Local Variables:
Copied: branches/html_cleanup/config/auto/llvm.pm (from r48747, trunk/config/auto/llvm.pm)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/config/auto/llvm.pm Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/config/auto/llvm.pm)
@@ -0,0 +1,247 @@
+# Copyright (C) 2009, Parrot Foundation.
+# $Id$
+
+=head1 NAME
+
+config/auto/llvm - Check whether the Low Level Virtual Machine is present
+
+=head1 DESCRIPTION
+
+Determines whether the Low Level Virtual Machine (LLVM) is installed and
+functional on the system. It is OK when it
+doesn't exist.
+
+=cut
+
+package auto::llvm;
+
+use strict;
+use warnings;
+
+use base qw(Parrot::Configure::Step);
+
+use Parrot::Configure::Utils ':auto';
+
+sub _init {
+ my $self = shift;
+ my %data;
+ $data{description} = q{Is LLVM installed};
+ $data{result} = q{};
+ $data{llvm_components} = [
+ [ 'llvm-gcc' => 'llvm-gcc' ],
+ [ 'lli' => 'Low Level Virtual Machine' ],
+ [ 'llc' => 'Low Level Virtual Machine' ],
+ ];
+ return \%data;
+}
+
+sub runstep {
+ my ( $self, $conf ) = @_;
+
+ my $verbose = $conf->options->get( 'verbose' );
+
+ # We start by seeing whether we can run three LLVM component executables,
+ # each with the '--version' option, and get the expected output.
+
+ my $llvm_lacking = 0;
+ foreach my $prog ( @{ $self->{llvm_components} } ) {
+ my $output = capture_output( $prog->[0], '--version' );
+ $llvm_lacking = _handle_component_version_output(
+ $prog, $output, $llvm_lacking, $verbose
+ );
+ }
+ my $output = q{};
+ $output = capture_output( 'llvm-gcc', '--version' );
+
+ # Next, we make sure we have at least major version 4 of 'llvm-gcc'
+ $llvm_lacking = _examine_llvm_gcc_version(
+ $output, $llvm_lacking, $verbose
+ );
+
+ # Finally, we see whether our LLVM actually works.
+ if ( $llvm_lacking ) {
+ $self->_handle_result( $conf, 0 );
+ }
+ else {
+
+ # Here we will take a simple C file, compile it into an LLVM bitcode
+ # file, execute it as bitcode, then compile it to native assembly
+ # using the LLC code generator, then assemble the native assembly
+ # language file into a program and execute it. Cf.:
+ # http://llvm.org/releases/2.5/docs/GettingStarted.html#overview
+
+ my $stem = q|hello|;
+ my $cfile = qq|$stem.c|;
+ my $fullcfile = qq|config/auto/llvm/$cfile|;
+ my $bcfile = qq|$stem.bc|;
+ my $sfile = qq|$stem.s|;
+ my $nativefile = qq|$stem.native|;
+ eval {
+ system(qq{llvm-gcc -O3 -emit-llvm $fullcfile -c -o $bcfile});
+ };
+ if ($@) {
+ $self->_handle_failure_to_compile_into_bitcode( $conf, $verbose );
+ }
+ else {
+ my $output;
+ eval {
+ $output = capture_output( 'lli', $bcfile );
+ };
+ if ( $@ or $output !~ /hello world/ ) {
+ $self->_handle_failure_to_execute_bitcode( $conf, $verbose );
+ }
+ else {
+ eval {
+ system(qq{llc $bcfile -o $sfile});
+ };
+ if ( $@ or (! -e $sfile) ) {
+ $self->_handle_failure_to_compile_to_assembly(
+ $conf, $verbose );
+ }
+ else {
+ eval {
+ my $cc = $conf->data->get('cc');
+ system(qq{$cc $sfile -o $nativefile});
+ };
+ if ( $@ or (! -e $nativefile) ) {
+ $self->_handle_failure_to_assemble_assembly(
+ $conf, $verbose );
+ }
+ else {
+ eval {
+ $output = capture_output(qq{./$nativefile});
+ };
+ $self->_handle_native_assembly_output(
+ $conf, $output, $verbose
+ );
+ }
+ }
+ }
+ }
+ my $count_unlinked = _cleanup_llvm_files(
+ $bcfile, $sfile, $nativefile
+ );
+ $conf->cc_clean();
+ }
+
+ return 1;
+}
+
+sub _handle_component_version_output {
+ my ($prog, $output, $llvm_lacking, $verbose) = @_;
+ my $exp = $prog->[1];
+ unless ( defined($output) and $output =~ m/$exp/s ) {
+ $llvm_lacking++;
+ print "Could not get expected '--version' output for $prog->[0]\n"
+ if $verbose;
+ }
+ else {
+ print $output, "\n" if $verbose;
+ }
+ return $llvm_lacking;
+}
+
+sub _examine_llvm_gcc_version {
+ my ( $output, $llvm_lacking, $verbose ) = @_;
+ if (! $output) {
+ $llvm_lacking++;
+ }
+ else {
+ my @line = split /\n+/, $output;
+ if ( $line[0] =~ m/\b(\d+)\.(\d+)\.(\d+)\b/ ) {
+ my @version = ($1, $2, $3);
+ if ($version[0] < 4) {
+ print "llvm-gcc must be at least major version 4\n"
+ if $verbose;
+ $llvm_lacking++;
+ }
+ }
+ else {
+ print "Unable to extract llvm-gcc major, minor and patch versions\n"
+ if $verbose;
+ $llvm_lacking++;
+ }
+ }
+ return $llvm_lacking;
+}
+
+sub _handle_failure_to_compile_into_bitcode {
+ my ($self, $conf, $verbose ) = @_;
+ print "Unable to compile C file into LLVM bitcode file\n"
+ if $verbose;
+ $self->_handle_result( $conf, 0 );
+}
+
+sub _handle_failure_to_execute_bitcode {
+ my ($self, $conf, $verbose ) = @_;
+ print "Unable to run LLVM bitcode file with 'lli'\n"
+ if $verbose;
+ $self->_handle_result( $conf, 0 );
+}
+
+sub _handle_failure_to_compile_to_assembly {
+ my ($self, $conf, $verbose ) = @_;
+ print "Unable to compile program to native assembly using 'llc'\n"
+ if $verbose;
+ $self->_handle_result( $conf, 0 );
+}
+
+sub _handle_failure_to_assemble_assembly {
+ my ($self, $conf, $verbose ) = @_;
+ print "Unable to assemble native assembly into program\n"
+ if $verbose;
+ $self->_handle_result( $conf, 0 );
+}
+
+sub _handle_result {
+ my ($self, $conf, $result) = @_;
+ if ( $result ) {
+ $self->set_result('yes');
+ $conf->data->set( has_llvm => 1 );
+ }
+ else {
+ $self->set_result('no');
+ $conf->data->set( has_llvm => '' );
+ }
+ return 1;
+}
+
+sub _handle_native_assembly_output {
+ my ($self, $conf, $output, $verbose) = @_;
+ if ( $@ or ( $output !~ /hello world/ ) ) {
+ print "Unable to execute native assembly program successfully\n"
+ if $verbose;
+ $self->_handle_result( $conf, 0 );
+ }
+ else {
+ $self->_handle_result( $conf, 1 );
+ }
+}
+
+sub _cleanup_llvm_files {
+ my @llvm_files = @_;
+ my $count_unlinked = 0;
+ foreach my $f ( @llvm_files ) {
+ if ( defined($f) and ( -e $f ) ) {
+ unlink $f;
+ $count_unlinked++;
+ }
+ }
+ return $count_unlinked;
+};
+
+1;
+
+=head1 AUTHOR
+
+James E Keenan
+
+=cut
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
+
Copied: branches/html_cleanup/config/auto/llvm/hello.c (from r48747, trunk/config/auto/llvm/hello.c)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/config/auto/llvm/hello.c Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/config/auto/llvm/hello.c)
@@ -0,0 +1,41 @@
+/*
+ *
+Copyright (C) 2009, Parrot Foundation.
+$Id$
+
+=head1
+
+Test file only.
+
+=over 4
+
+=item C<int main()>
+
+Test file only.
+
+=cut
+
+*/
+
+#include <stdio.h>
+
+int main() {
+ printf("hello world\n");
+ return 0;
+}
+
+/*
+
+=back
+
+=cut
+
+*/
+
+
+/*
+ * Local variables:
+ * c-file-style: "parrot"
+ * End:
+ * vim: expandtab shiftwidth=4:
+ */
Modified: branches/html_cleanup/config/gen/makefiles/root.in
==============================================================================
--- branches/html_cleanup/config/gen/makefiles/root.in Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/config/gen/makefiles/root.in Wed Sep 1 06:33:06 2010 (r48748)
@@ -47,8 +47,13 @@
# where we're building parrot from (needed for pbc_to_exe)
BUILD_DIR = @build_dir@
-# directory for build tools
+# directory for build tools:
+# programs, templates, configuration files invoked by 'make all'
+# (with or without command-line options)
BUILD_TOOLS_DIR = tools/build
+# directory for developers' tools
+# programs, templates, configuration files NOT invoked by 'make all'
+DEV_TOOLS_DIR = tools/dev
# directory for header files
INC_DIR = @inc@
@@ -116,7 +121,7 @@
NONGEN_HEADERS = @TEMP_nongen_headers@
# The headerizer
-HEADERIZER = $(PERL) $(BUILD_TOOLS_DIR)/headerizer.pl
+HEADERIZER = $(PERL) $(DEV_TOOLS_DIR)/headerizer.pl
include src/dynpmc/Defines.mak
include src/dynoplibs/Defines.mak
@@ -842,12 +847,12 @@
@rpath_blib@ $(ALL_PARROT_LIBS) $(LINKFLAGS) $(LINK_DYNAMIC)
#IF(win32): if exist $@.manifest mt.exe -nologo -manifest $@.manifest -outputresource:$@;1
-$(PBC_TO_EXE) : tools/dev/pbc_to_exe.pir runtime/parrot/library/config.pir $(PARROT) $(DYNEXT_DIR)/os$(LOAD_EXT) $(DYNEXT_DIR)/file$(LOAD_EXT) $(LIBRARY_DIR)/Getopt/Obj.pbc
- $(PARROT) -o pbc_to_exe.pbc tools/dev/pbc_to_exe.pir
+$(PBC_TO_EXE) : $(DEV_TOOLS_DIR)/pbc_to_exe.pir runtime/parrot/library/config.pir $(PARROT) $(DYNEXT_DIR)/os$(LOAD_EXT) $(DYNEXT_DIR)/file$(LOAD_EXT)
+ $(PARROT) -o pbc_to_exe.pbc $(DEV_TOOLS_DIR)/pbc_to_exe.pir
$(PARROT) pbc_to_exe.pbc pbc_to_exe.pbc
-parrot_nci_thunk_gen.pbc : tools/dev/nci_thunk_gen.pir $(DATA_JSON_LIB_PBCS) $(PARROT)
- $(PARROT) -o parrot_nci_thunk_gen.pbc tools/dev/nci_thunk_gen.pir
+parrot_nci_thunk_gen.pbc : $(DEV_TOOLS_DIR)/nci_thunk_gen.pir $(DATA_JSON_LIB_PBCS) $(PARROT)
+ $(PARROT) -o parrot_nci_thunk_gen.pbc $(DEV_TOOLS_DIR)/nci_thunk_gen.pir
$(NCI_THUNK_GEN) : parrot_nci_thunk_gen.pbc $(PBC_TO_EXE)
$(PBC_TO_EXE) parrot_nci_thunk_gen.pbc
@@ -858,8 +863,8 @@
$(PROVE) : parrot-prove.pbc $(PARROT) $(PBC_TO_EXE)
$(PBC_TO_EXE) parrot-prove.pbc
-$(PARROT_CONFIG) : tools/util/parrot-config.pir $(PARROT) $(PBC_TO_EXE)
- $(PARROT) -o parrot_config.pbc tools/util/parrot-config.pir
+$(PARROT_CONFIG) : $(DEV_TOOLS_DIR)/parrot-config.pir $(PARROT) $(PBC_TO_EXE)
+ $(PARROT) -o parrot_config.pbc $(DEV_TOOLS_DIR)/parrot-config.pir
$(PARROT) pbc_to_exe.pbc parrot_config.pbc
$(MINIPARROT) : src/main$(O) $(GEN_HEADERS) $(LIBPARROT) \
@@ -936,10 +941,10 @@
$(IMCC_O_FILES)
lib_deps_object : $(O_FILES)
- $(PERL) tools/dev/lib_deps.pl object $(O_FILES)
+ $(PERL) $(DEV_TOOLS_DIR)/lib_deps.pl object $(O_FILES)
lib_deps_source : $(GENERAL_H_FILES)
- $(PERL) tools/dev/lib_deps.pl source all_source
+ $(PERL) $(DEV_TOOLS_DIR)/lib_deps.pl source all_source
lib_deps : lib_deps_object lib_deps_source
@@ -969,7 +974,7 @@
$(INSTALLABLECONFIG) : src/install_config$(O) $(PARROT_CONFIG) $(PBC_TO_EXE)
- $(PARROT) -o parrot_config.pbc tools/util/parrot-config.pir
+ $(PARROT) -o parrot_config.pbc $(DEV_TOOLS_DIR)/parrot-config.pir
$(PBC_TO_EXE) parrot_config.pbc --install
$(INSTALLABLEPBCTOEXE) : $(PBC_TO_EXE) src/install_config$(O)
@@ -1251,7 +1256,7 @@
src/pmc_freeze$(O) : $(PARROT_H_HEADERS) src/pmc_freeze.str src/pmc_freeze.c
-src/hash$(O) : $(PARROT_H_HEADERS) include/pmc/pmc_key.h src/hash.c
+src/hash$(O) : $(PARROT_H_HEADERS) src/hash.c
src/library$(O) : $(PARROT_H_HEADERS) src/library.str src/library.c\
$(INC_DIR)/dynext.h
@@ -1997,19 +2002,19 @@
# Require .svn to exist first
# Otherwise it'll remove every last file
svnclobber : .svn
- $(PERL) tools/dev/svnclobber.pl
+ $(PERL) $(DEV_TOOLS_DIR)/svnclobber.pl
reconfig : realclean
$(PERL) Configure.pl $(CONFIG_ARGS)
manitest :
- $(PERL) tools/dev/manicheck.pl
+ $(PERL) $(DEV_TOOLS_DIR)/manicheck.pl
opsrenumber :
- $(PERL) tools/dev/opsrenumber.pl $(OPS_FILES)
+ $(PERL) $(DEV_TOOLS_DIR)/opsrenumber.pl $(OPS_FILES)
pmcrenumber :
- $(PERL) tools/dev/pmcrenumber.pl src/pmc/pmc.num
+ $(PERL) $(DEV_TOOLS_DIR)/pmcrenumber.pl src/pmc/pmc.num
###############################################################################
#
@@ -2361,7 +2366,7 @@
install-dev: install
install-bin: installable
- $(PERL) tools/dev/install_files.pl \
+ $(PERL) $(DEV_TOOLS_DIR)/install_files.pl \
--buildprefix=$(BUILDPREFIX) \
--prefix=$(PREFIX) \
--exec-prefix=$(EXEC_PREFIX) \
@@ -2375,7 +2380,7 @@
MANIFEST MANIFEST.generated
install-dev-only: installable
- $(PERL) tools/dev/install_dev_files.pl \
+ $(PERL) $(DEV_TOOLS_DIR)/install_dev_files.pl \
--buildprefix=$(BUILDPREFIX) \
--prefix=$(PREFIX) \
--exec-prefix=$(EXEC_PREFIX) \
@@ -2390,7 +2395,7 @@
MANIFEST MANIFEST.generated
install-doc:
- $(PERL) tools/dev/install_doc_files.pl \
+ $(PERL) $(DEV_TOOLS_DIR)/install_doc_files.pl \
--buildprefix=$(BUILDPREFIX) \
--prefix=$(PREFIX) \
--docdir=$(DOC_DIR) \
@@ -2419,7 +2424,7 @@
rm parrot-$(VERSION)
win32-inno-installer : world installable
- $(PERL) tools/dev/mk_inno.pl
+ $(PERL) $(DEV_TOOLS_DIR)/mk_inno.pl
$(INNO_SETUP) parrot.iss
###############################################################################
@@ -2513,7 +2518,7 @@
--languages=c,perl --langmap=c:+.h,c:+.pmc,c:+.ops \
-I NOTNULL,NULLOK,ARGIN,ARGMOD,ARGOUT,ARGINOUT,ARGIN_NULLOK,ARGOUT_NULLOK,ARGMOD_NULLOK,ARGFREE,ARGFREE_NOTNULL \
.
- $(PERL) $(BUILD_TOOLS_DIR)/addopstags.pl $(OPS_FILES)
+ $(PERL) $(DEV_TOOLS_DIR)/addopstags.pl $(OPS_FILES)
tags.vi.dummy:
@@ -2525,12 +2530,12 @@
CRITIC_FILES = 'lib/Parrot'
perlcritic:
- perlcritic --profile tools/util/perlcritic.conf $(CRITIC_FILES)
+ perlcritic --profile $(DEV_TOOLS_DIR)/perlcritic.conf $(CRITIC_FILES)
# Andy's extra-cranky Perl::Critic checking for cage cleaners
cagecritic:
@perl -MPerl::Critic::Bangs -e'$$min=q{1.04};die qq{You need Bangs $$min} unless $$Perl::Critic::Bangs::VERSION ge $$min'
- perlcritic -1 --profile tools/util/perlcritic-cage.conf $(CRITIC_FILES)
+ perlcritic -1 --profile $(DEV_TOOLS_DIR)/perlcritic-cage.conf $(CRITIC_FILES)
# This target will eventually create all the headers automatically. If you
# are having problems with linkage in Win32 (or elsewhere), because something
Modified: branches/html_cleanup/docs/project/release_manager_guide.pod
==============================================================================
--- branches/html_cleanup/docs/project/release_manager_guide.pod Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/docs/project/release_manager_guide.pod Wed Sep 1 06:33:06 2010 (r48748)
@@ -84,7 +84,7 @@
=item c
-Update release-related information in F<tools/util/release.json>. This will be
+Update release-related information in F<tools/release/release.json>. This will be
used later when making release announcements. There are a few essential
fields that must be updated at each release:
@@ -118,16 +118,9 @@
=item f
-In the two files F<src/ops/core_ops.c> and F<include/parrot/oplib/core_ops.h>
-is the function C<Parrot_DynOp_core_a_b_c>, which has a name that includes
-the version number. a_b_c is the version number. You have to update this
-version number on two places in the file F<src/ops/core_ops.c>.
-In the file F<include/parrot/oplib/core_ops.h> you have to change this line:
-
- op_lib_t *Parrot_DynOp_core_a_b_c(PARROT_INTERP, long init);
-
-Ignore the warning to not edit this files. It is necessary to edit this files,
-so that "make" builds with the increased version number.
+Run C<./ops2c --core> (or C<make bootstrap-ops>, ignoring errors) followed by
+C<make reconfig> and C<make> to update the names of version-specific internal
+functions.
=item g
@@ -251,11 +244,11 @@
=item 9.
-Compose the release announcement. Use F<tools/util/crow.pir> to make
+Compose the release announcement. Use F<tools/release/crow.pir> to make
this part easier. You can specify the format of your announcements like so:
- $ ./parrot tools/util/crow.pir --type=text
- $ ./parrot tools/util/crow.pir --type=html
+ $ ./parrot tools/release/crow.pir --type=text
+ $ ./parrot tools/release/crow.pir --type=html
Take the screen output and paste it into the application you need. HTML
works well for use Perl and PerlMonks, and text for the rest. It is not a
Copied: branches/html_cleanup/examples/tools/pgegrep (from r48747, trunk/examples/tools/pgegrep)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/examples/tools/pgegrep Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/examples/tools/pgegrep)
@@ -0,0 +1,308 @@
+#! parrot
+
+=head1 NAME
+
+pgegrep - A simple grep using PGE for matching
+
+=head1 SYNOPSIS
+
+B<pgegrep> [I<OPTIONS>] B<PATTERN> [I<FILE...>]
+
+=head1 DESCRIPTION
+
+pgegrep aims to be a small and easy to use program in replacement of the
+standard grep utility. Regex support is whatever PGE will allow. It
+searches through files line by line and tests if the given pattern matches.
+
+=head1 OPTIONS
+
+=over 4
+
+=item -v
+
+=item --invert-match
+
+print lines not matching PATTERN
+
+=item -V
+
+=item --version
+
+print the version and exit
+
+=item --help
+
+show this help and exit
+
+=item -r
+
+=item --recursive
+
+recursively descend into directories
+
+=item -L
+
+=item --files-without-matches
+
+print a list of files that do not match PATTERN
+
+=item -l
+
+=item --files-with-matches
+
+print a list of files that do match PATTERN
+
+=item -a
+
+=item --text
+
+treat binary files as text.
+
+This uses a basic heuristic to discover if a file is binary or not. Files are
+read line by line, and it keeps processing "normally" until a control character
+is found, and then stops and goes onto the next file is that line matches.
+
+=item -n
+
+=item --line-number
+
+print the line number for each match
+
+=item -H
+
+=item --with-filename
+
+print the filename for each match
+
+=back
+
+=cut
+
+# Readability improved!
+.include 'hllmacros.pir'
+
+# for getstdin and friends
+.loadlib 'io_ops'
+
+.sub main :main
+ .param pmc argv # the script name, then our options.
+ .local string progname
+ progname = shift argv
+ load_bytecode 'Getopt/Obj.pbc'
+ load_bytecode 'PGE.pbc'
+ .local pmc getopts
+ getopts = new [ 'Getopt';'Obj' ]
+ getopts.'notOptStop'(1)
+ push getopts, 'with-filename|H'
+ push getopts, 'files-with-matches|l'
+ push getopts, 'files-without-matches|L'
+ push getopts, 'line-number|n'
+ push getopts, 'text|a'
+ push getopts, 'recursive|r'
+ push getopts, 'invert-match|v'
+ push getopts, 'version|V'
+ push getopts, 'help'
+ push_eh handler
+ .local pmc opts
+ opts = getopts.'get_options'(argv)
+ $I0 = defined opts['help']
+ .If($I0, {
+ showhelp()
+ })
+ $I0 = defined opts['version']
+ .If($I0, {
+ showversion()
+ })
+
+ .local int argc
+ argc = elements argv
+ .Unless(argc>1, { showhelp() }) # need rule and at least one file
+
+ .local string rule
+ .local pmc p6rule_compile, matchsub
+ rule = shift argv
+ p6rule_compile = compreg 'PGE::Perl6Regex'
+ matchsub = p6rule_compile(rule)
+ .If(null matchsub, { die 'Unable to compile regex' })
+
+ .local int i, filecount
+ .local string filename
+ .local pmc File, OS, files, handle
+ files = new 'ResizableStringArray'
+ files = argv
+ filecount = files
+ # define with-filename if there's more than one file
+ .If(filecount >= 2, { opts['with-filename'] = 1 })
+ $P0 = loadlib 'file'
+ File = new 'File'
+ $P0 = loadlib 'os'
+ OS = new 'OS'
+ # This must be here, or else it'll get filled with junk data we use stdin...
+ i = 0
+
+ .Unless(filecount, {
+ # no args, use stdin
+ stdindashhack:
+ handle = getstdin
+ filename = '(standard input)'
+ goto stdinhack
+ })
+ .For(, i < filecount, inc i, {
+ filename = files[i]
+ .If(filename == '-', {
+ goto stdindashhack
+ })
+ $I1 = File.'is_file'(filename)
+ .IfElse($I1, {
+ # Is a file
+ handle = open filename, 'r'
+ },{
+ # Not a file, hopefully a directory
+ $I1 = File.'is_dir'(filename)
+ $I0 = defined opts['recursive']
+ $I1 &= $I0
+ .Unless($I1, {
+ printerr "pgegrep: '"
+ printerr filename
+ printerr "': Operation not supported.\n"
+ goto nextfor_0
+ })
+ $P0 = OS.'readdir'(filename)
+ .Foreach($S0, $P0, {
+ .If($S0 != '.', {
+ .If($S0 != '..', {
+ $S1 = filename . '/'
+ $S0 = $S1 . $S0
+ $P1 = new 'ResizableStringArray'
+ $P1[0] = $S0
+ $I0 = i + 1
+ splice files, $P1, $I0, 0
+ }) })
+ })
+ filecount = files
+ goto nextfor_0
+ })
+ stdinhack:
+ checkfile(handle, filename, matchsub, opts)
+ close handle
+ nextfor_0:
+ })
+
+ end
+handler:
+ .local pmc exception, pmcmsg
+ .local string message
+ .get_results (exception)
+ pmcmsg = getattribute exception, 'message'
+ pop_eh
+ message = pmcmsg
+ message = "pgegrep: " . message
+ die message
+.end
+
+.sub checkfile
+ .param pmc handle
+ .param string filename
+ .param pmc matchsub
+ .param pmc opts
+
+ .local pmc match
+ .local string line
+ .local int lineno, linelen, matched
+ lineno = 1
+ matched = 0 # Only used for --files-without-matches
+ line = readline handle
+ linelen = length line
+
+ .local pmc p6rule_compile, cntrlchar
+ $S0 = '<+cntrl-[\t\r\n]>'
+ p6rule_compile = compreg 'PGE::Perl6Regex'
+ cntrlchar = p6rule_compile($S0)
+
+ .For(, linelen, {
+ line = readline handle
+ linelen = length line
+ inc lineno
+ }, {
+ match = matchsub(line)
+ $I1 = istrue match
+ match = cntrlchar(line)
+
+ $I2 = istrue match
+ $I0 = defined opts['files-without-matches']
+ .If($I0, {
+ .If($I1, { matched = 1 })
+ goto next
+ })
+ $I0 = defined opts['files-with-matches']
+ $I0 = $I0 && $I1
+ .If($I0, {
+ say filename
+ .return()
+ })
+
+ $I0 = defined opts['invert-match']
+ not $I0
+ $I1 = xor $I1, $I0
+ .Unless($I1, {
+ $I0 = defined opts['text']
+ $I0 = xor $I0, $I2
+ .If($I0, {
+ print 'Binary file '
+ print filename
+ say ' matches'
+ .return()
+ })
+ $I0 = defined opts['with-filename']
+ $I1 = defined opts['recursive']
+ $I0 = $I0 || $I1
+ .If($I0, {
+ print filename
+ print ':'
+ })
+ $I0 = defined opts['line-number']
+ .If($I0, {
+ print lineno
+ print ':'
+ })
+ print line
+ })
+ #---------
+ next:
+ })
+ $I0 = defined opts['files-without-matches']
+ .If($I0, { say filename })
+ .return()
+.end
+
+.sub showhelp
+ print <<'HELP'
+Usage: pgegrep [OPTIONS] PATTERN [FILE...]
+Search for the Perl 6 Rule PATTERN in each file.
+
+ -v --invert-match print lines not matching PATTERN
+ -V --version print the version and exit
+ --help show this help and exit
+ -r --recursive recursively descend into directories
+ -L --files-without-matches print a list of files that do not match PATTERN
+ -l --files-with-matches print a list of files that do match PATTERN
+ -a --text treat binary files as text
+ -n --line-number print the line number for each match
+ -H --with-filename print the filename for each match
+
+HELP
+ end
+.end
+
+.sub showversion
+ print <<'VERSION'
+pgegrep v0.0.1
+VERSION
+ end
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Modified: branches/html_cleanup/include/parrot/hash.h
==============================================================================
--- branches/html_cleanup/include/parrot/hash.h Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/include/parrot/hash.h Wed Sep 1 06:33:06 2010 (r48748)
@@ -233,19 +233,40 @@
Hash * parrot_new_pointer_hash(PARROT_INTERP)
__attribute__nonnull__(1);
-PARROT_CANNOT_RETURN_NULL
-PMC* get_integer_pmc(PARROT_INTERP, INTVAL value)
- __attribute__nonnull__(1);
+PARROT_WARN_UNUSED_RESULT
+PARROT_CONST_FUNCTION
+int hash_compare_int(SHIM_INTERP,
+ ARGIN_NULLOK(const void *a),
+ ARGIN_NULLOK(const void *b));
-PARROT_CANNOT_RETURN_NULL
-PMC* get_number_pmc(PARROT_INTERP, FLOATVAL value)
- __attribute__nonnull__(1);
+PARROT_WARN_UNUSED_RESULT
+PARROT_PURE_FUNCTION
+int hash_compare_pmc(PARROT_INTERP, ARGIN(PMC *a), ARGIN(PMC *b))
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2)
+ __attribute__nonnull__(3);
-PARROT_CANNOT_RETURN_NULL
-PMC * get_string_pmc(PARROT_INTERP, ARGIN(STRING *value))
+PARROT_WARN_UNUSED_RESULT
+PARROT_CONST_FUNCTION
+int hash_compare_pointer(SHIM_INTERP,
+ ARGIN_NULLOK(const void *a),
+ ARGIN_NULLOK(const void *b));
+
+PARROT_WARN_UNUSED_RESULT
+int hash_compare_string(PARROT_INTERP,
+ ARGIN(const void *search_key),
+ ARGIN_NULLOK(const void *bucket_key))
__attribute__nonnull__(1)
__attribute__nonnull__(2);
+PARROT_WARN_UNUSED_RESULT
+int hash_compare_string_distinct_enc(PARROT_INTERP,
+ ARGIN(const void *search_key),
+ ARGIN(const void *bucket_key))
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2)
+ __attribute__nonnull__(3);
+
PARROT_CAN_RETURN_NULL
void* hash_key_from_int(PARROT_INTERP, ARGIN(const Hash *hash), INTVAL key)
__attribute__nonnull__(1)
@@ -344,12 +365,6 @@
PARROT_WARN_UNUSED_RESULT
PARROT_CONST_FUNCTION
-int int_compare(SHIM_INTERP,
- ARGIN_NULLOK(const void *a),
- ARGIN_NULLOK(const void *b));
-
-PARROT_WARN_UNUSED_RESULT
-PARROT_CONST_FUNCTION
size_t key_hash_int(SHIM_INTERP,
ARGIN_NULLOK(const void *value),
size_t seed);
@@ -431,28 +446,6 @@
__attribute__nonnull__(2)
FUNC_MODIFIES(*info);
-PARROT_WARN_UNUSED_RESULT
-PARROT_PURE_FUNCTION
-int PMC_compare(PARROT_INTERP, ARGIN(PMC *a), ARGIN(PMC *b))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3);
-
-PARROT_WARN_UNUSED_RESULT
-int STRING_compare(PARROT_INTERP,
- ARGIN(const void *search_key),
- ARGIN_NULLOK(const void *bucket_key))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2);
-
-PARROT_WARN_UNUSED_RESULT
-int STRING_compare_distinct_cs_enc(PARROT_INTERP,
- ARGIN(const void *search_key),
- ARGIN(const void *bucket_key))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3);
-
#define ASSERT_ARGS_parrot_dump_hash __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
#define ASSERT_ARGS_parrot_hash_clone __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
@@ -492,13 +485,20 @@
PARROT_ASSERT_ARG(interp))
#define ASSERT_ARGS_parrot_new_pointer_hash __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp))
-#define ASSERT_ARGS_get_integer_pmc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp))
-#define ASSERT_ARGS_get_number_pmc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp))
-#define ASSERT_ARGS_get_string_pmc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+#define ASSERT_ARGS_hash_compare_int __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
+#define ASSERT_ARGS_hash_compare_pmc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(value))
+ , PARROT_ASSERT_ARG(a) \
+ , PARROT_ASSERT_ARG(b))
+#define ASSERT_ARGS_hash_compare_pointer __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
+#define ASSERT_ARGS_hash_compare_string __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(interp) \
+ , PARROT_ASSERT_ARG(search_key))
+#define ASSERT_ARGS_hash_compare_string_distinct_enc \
+ __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(interp) \
+ , PARROT_ASSERT_ARG(search_key) \
+ , PARROT_ASSERT_ARG(bucket_key))
#define ASSERT_ARGS_hash_key_from_int __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(hash))
@@ -544,7 +544,6 @@
#define ASSERT_ARGS_hash_value_to_string __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(hash))
-#define ASSERT_ARGS_int_compare __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
#define ASSERT_ARGS_key_hash_int __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
#define ASSERT_ARGS_key_hash_PMC __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
@@ -578,18 +577,6 @@
#define ASSERT_ARGS_Parrot_hash_thaw __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(info))
-#define ASSERT_ARGS_PMC_compare __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(a) \
- , PARROT_ASSERT_ARG(b))
-#define ASSERT_ARGS_STRING_compare __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(search_key))
-#define ASSERT_ARGS_STRING_compare_distinct_cs_enc \
- __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(search_key) \
- , PARROT_ASSERT_ARG(bucket_key))
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
/* HEADERIZER END: src/hash.c */
Modified: branches/html_cleanup/include/parrot/scheduler_private.h
==============================================================================
--- branches/html_cleanup/include/parrot/scheduler_private.h Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/include/parrot/scheduler_private.h Wed Sep 1 06:33:06 2010 (r48748)
@@ -19,7 +19,8 @@
typedef enum {
SCHEDULER_cache_valid_FLAG = PObj_private0_FLAG,
SCHEDULER_wake_requested_FLAG = PObj_private1_FLAG,
- SCHEDULER_terminate_requested_FLAG = PObj_private2_FLAG
+ SCHEDULER_terminate_requested_FLAG = PObj_private2_FLAG,
+ SCHEDULER_in_handler_FLAG = PObj_private3_FLAG
} scheduler_flags_enum;
#define SCHEDULER_get_FLAGS(o) (PObj_get_FLAGS(o))
@@ -42,6 +43,11 @@
#define SCHEDULER_terminate_requested_SET(o) SCHEDULER_flag_SET(terminate_requested, o)
#define SCHEDULER_terminate_requested_CLEAR(o) SCHEDULER_flag_CLEAR(terminate_requested, o)
+/* Mark if the scheduler is inside a handler */
+#define SCHEDULER_in_handler_TEST(o) SCHEDULER_flag_TEST(in_handler, o)
+#define SCHEDULER_in_handler_SET(o) SCHEDULER_flag_SET(in_handler, o)
+#define SCHEDULER_in_handler_CLEAR(o) SCHEDULER_flag_CLEAR(in_handler, o)
+
/*
* Task private flags
*/
Modified: branches/html_cleanup/lib/Parrot/Configure/Step/List.pm
==============================================================================
--- branches/html_cleanup/lib/Parrot/Configure/Step/List.pm Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/lib/Parrot/Configure/Step/List.pm Wed Sep 1 06:33:06 2010 (r48748)
@@ -41,6 +41,7 @@
auto::isreg
auto::jit
auto::frames
+ auto::llvm
auto::inline
auto::gc
auto::memalign
Modified: branches/html_cleanup/lib/Parrot/Docs/Section/Tools.pm
==============================================================================
--- branches/html_cleanup/lib/Parrot/Docs/Section/Tools.pm Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/lib/Parrot/Docs/Section/Tools.pm Wed Sep 1 06:33:06 2010 (r48748)
@@ -85,7 +85,7 @@
$self->new_item( '', 'tools/dev/list_unjitted.pl' ),
$self->new_item( '', 'tools/dev/gen_class.pl' ),
$self->new_item( '', 'tools/dev/nm.pl' ),
- $self->new_item( '', 'tools/util/ncidef2pasm.pl' ),
+ $self->new_item( '', 'tools/dev/ncidef2pasm.pl' ),
$self->new_item( '', 'tools/dev/pbc_header.pl' ),
),
$self->new_group(
Modified: branches/html_cleanup/ports/debian/rules
==============================================================================
--- branches/html_cleanup/ports/debian/rules Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/ports/debian/rules Wed Sep 1 06:33:06 2010 (r48748)
@@ -42,7 +42,7 @@
dh_testdir
$(MAKE) installable LD_LIBRARY_PATH=${LD_LIBRARY_PATH:+$LD_LIBRARY_PATH:}`pwd`/blib/lib
pod2man --section=1 --release="Debian Project" --center="Debian GNU/Linux manual" docs/running.pod debian/parrot.1
- pod2man --section=1 --release="Debian Project" --center="Debian GNU/Linux manual" tools/util/parrot-config.pir debian/parrot_config.1
+ pod2man --section=1 --release="Debian Project" --center="Debian GNU/Linux manual" tools/dev/parrot-config.pir debian/parrot_config.1
pod2man --section=1 --release="Debian Project" --center="Debian GNU/Linux manual" src/pbc_dump.c debian/pbc_dump.1
pod2man --section=1 --release="Debian Project" --center="Debian GNU/Linux manual" src/pbc_disassemble.c debian/pbc_disassemble.1
pod2man --section=1 --release="Debian Project" --center="Debian GNU/Linux manual" src/parrot_debugger.c debian/parrot_debugger.1
Modified: branches/html_cleanup/src/dynext.c
==============================================================================
--- branches/html_cleanup/src/dynext.c Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/dynext.c Wed Sep 1 06:33:06 2010 (r48748)
@@ -1,5 +1,5 @@
/*
-Copyright (C) 2001-2008, Parrot Foundation.
+Copyright (C) 2001-2010, Parrot Foundation.
$Id$
=head1 NAME
@@ -145,8 +145,7 @@
=item C<static void set_cstring_prop(PARROT_INTERP, PMC *lib_pmc, const char
*what, STRING *name)>
-Set a property C<name> with value C<what> on the C<ParrotLibrary>
-C<lib_pmc>.
+Sets a property C<name> with value C<what> on the C<ParrotLibrary> C<lib_pmc>.
=cut
@@ -164,12 +163,13 @@
VTABLE_setprop(interp, lib_pmc, key, prop);
}
+
/*
=item C<static void store_lib_pmc(PARROT_INTERP, PMC *lib_pmc, STRING *path,
STRING *type, STRING *lib_name)>
-Store a C<ParrotLibrary> PMC in the interpreter's C<iglobals>.
+Stores a C<ParrotLibrary> PMC in the interpreter's C<iglobals>.
=cut
@@ -194,12 +194,13 @@
VTABLE_set_pmc_keyed_str(interp, dyn_libs, path, lib_pmc);
}
+
/*
=item C<static PMC* is_loaded(PARROT_INTERP, STRING *path)>
-Check if a C<ParrotLibrary> PMC with the filename path exists.
-If it does, return it. Otherwise, return NULL.
+Returns a C<ParrotLibrary> PMC with the given filename path, if it exists.
+Otherwise returns PMCNULL.
=cut
@@ -214,17 +215,16 @@
PMC * const iglobals = interp->iglobals;
PMC * const dyn_libs = VTABLE_get_pmc_keyed_int(interp, iglobals,
IGLOBALS_DYN_LIBS);
- if (!VTABLE_exists_keyed_str(interp, dyn_libs, path))
- return PMCNULL;
return VTABLE_get_pmc_keyed_str(interp, dyn_libs, path);
}
+
/*
=item C<static void * dlopen_string(PARROT_INTERP, Parrot_dlopen_flags flags,
STRING *path)>
-Call Parrot_dlopen with the Parrot String argument converted to C string. The
+Calls C<Parrot_dlopen> with the path argument converted to a C string. The
flags argument will be converted into native form and used if applicable.
=cut
@@ -244,12 +244,13 @@
return handle;
}
+
/*
=item C<static STRING * get_path(PARROT_INTERP, STRING *lib, Parrot_dlopen_flags
flags, void **handle, STRING *wo_ext, STRING *ext)>
-Return path and handle of a dynamic lib, setting lib_name to just the filestem
+Returns path and handle of a dynamic lib, setting lib_name to just the filestem
(i.e. without path or extension) as a freshly-allocated C string.
=cut
@@ -264,75 +265,76 @@
ARGIN_NULLOK(STRING *ext))
{
ASSERT_ARGS(get_path)
- STRING *path, *full_name;
- const char *err = NULL; /* buffer returned from Parrot_dlerror */
-
- PMC * const iglobals = interp->iglobals;
+ PMC * const iglobals = interp->iglobals;
PMC * const lib_paths = VTABLE_get_pmc_keyed_int(interp, iglobals,
IGLOBALS_LIB_PATHS);
PMC * const share_ext = VTABLE_get_pmc_keyed_int(interp, lib_paths,
PARROT_LIB_DYN_EXTS);
- if (lib == NULL) {
+ STRING *path, *full_name;
+
+ if (! lib) {
*handle = Parrot_dlopen((char *)NULL, flags);
- if (*handle) {
+ if (*handle)
return CONST_STRING(interp, "");
+ else {
+ const char *err = Parrot_dlerror();
+ Parrot_warn(interp, PARROT_WARNINGS_DYNEXT_FLAG,
+ "Couldn't dlopen(NULL): %s\n",
+ err ? err : "unknown reason");
+ return NULL;
}
- err = Parrot_dlerror();
- Parrot_warn(interp, PARROT_WARNINGS_DYNEXT_FLAG,
- "Couldn't dlopen(NULL): %s\n",
- err ? err : "unknown reason");
- return NULL;
}
- /*
- * first, try to add an extension to the file if it has none.
- */
+ /* first, try to add an extension to the file if it has none */
if (! ext) {
const INTVAL n = VTABLE_elements(interp, share_ext);
- INTVAL i;
+ INTVAL i;
for (i = 0; i < n; ++i) {
- ext = VTABLE_get_string_keyed_int(interp, share_ext, i);
+ ext = VTABLE_get_string_keyed_int(interp, share_ext, i);
full_name = Parrot_str_concat(interp, wo_ext, ext);
- path = Parrot_locate_runtime_file_str(interp, full_name,
- PARROT_RUNTIME_FT_DYNEXT);
+ path = Parrot_locate_runtime_file_str(interp, full_name,
+ PARROT_RUNTIME_FT_DYNEXT);
+
if (path) {
*handle = dlopen_string(interp, flags, path);
- if (*handle) {
+
+ if (*handle)
return path;
+ else {
+ const char *err = Parrot_dlerror();
+ Parrot_warn(interp, PARROT_WARNINGS_DYNEXT_FLAG,
+ "Couldn't load '%Ss': %s\n",
+ full_name, err ? err : "unknown reason");
+ return NULL;
}
- err = Parrot_dlerror();
- Parrot_warn(interp, PARROT_WARNINGS_DYNEXT_FLAG,
- "Couldn't load '%Ss': %s\n",
- full_name, err ? err : "unknown reason");
- return NULL;
}
- /*
- * File with extension and prefix was not found,
- * so try file.extension w/o prefix
- */
+ /* File not found with extension and prefix; try file.extension */
*handle = dlopen_string(interp, flags, full_name);
- if (*handle) {
+ if (*handle)
return full_name;
- }
}
}
+
/*
* finally, try the given file name as is. We still use
* Parrot_locate_runtime_file so that (a) relative pathnames are searched in
* the standard locations, and (b) the angle of the slashes are adjusted as
* required for non-Unix systems.
*/
+
full_name = Parrot_locate_runtime_file_str(interp, lib,
- PARROT_RUNTIME_FT_DYNEXT);
+ PARROT_RUNTIME_FT_DYNEXT);
+
if (full_name) {
*handle = dlopen_string(interp, flags, full_name);
- if (*handle) {
+
+ if (*handle)
return full_name;
- }
}
+
/*
* and on windows strip a leading "lib"
* [shouldn't this happen in Parrot_locate_runtime_file instead?]
@@ -340,10 +342,9 @@
#ifdef WIN32
if (!STRING_IS_EMPTY(lib) && memcmp(lib->strstart, "lib", 3) == 0) {
*handle = Parrot_dlopen((char *)lib->strstart + 3, 0);
- if (*handle) {
- path = Parrot_str_substr(interp, lib, 3, lib->strlen - 3);
- return path;
- }
+
+ if (*handle)
+ return Parrot_str_substr(interp, lib, 3, lib->strlen - 3);
}
#endif
@@ -360,20 +361,22 @@
}
#endif
- /* And after-finally, let the OS use his own search */
- if (!STRING_IS_EMPTY(lib)) {
+ if (STRING_IS_EMPTY(lib)) {
*handle = dlopen_string(interp, flags, lib);
if (*handle)
return lib;
}
-
- err = Parrot_dlerror();
- Parrot_warn(interp, PARROT_WARNINGS_DYNEXT_FLAG,
- "Couldn't load '%Ss': %s\n",
- lib, err ? err : "unknown reason");
- return NULL;
+ /* And after-finally, let the OS use his own search */
+ {
+ const char *err = Parrot_dlerror();
+ Parrot_warn(interp, PARROT_WARNINGS_DYNEXT_FLAG,
+ "Couldn't load '%Ss': %s\n",
+ lib, err ? err : "unknown reason");
+ return NULL;
+ }
}
+
/*
=item C<PMC * Parrot_init_lib(PARROT_INTERP, dynext_load_func load_func,
@@ -411,12 +414,13 @@
return lib_pmc;
}
+
/*
=item C<void * Parrot_dlsym_str(PARROT_INTERP, void *handle, STRING *symbol)>
-Same as Parrot_dlsym but takes the symbol name from a Parrot String instead
-of a C string.
+Loads a symbol named C<symbol> from the shared library represented by
+C<handle>.
=cut
@@ -430,25 +434,26 @@
{
ASSERT_ARGS(Parrot_dlsym_str)
- void *ptr;
if (STRING_IS_NULL(symbol))
- ptr = NULL;
+ return NULL;
+
else {
char *const symbol_cs = Parrot_str_to_cstring(interp, symbol);
- ptr = Parrot_dlsym(handle, symbol_cs);
+ void *ptr = Parrot_dlsym(handle, symbol_cs);
Parrot_str_free_cstring(symbol_cs);
+ return ptr;
}
- return ptr;
}
+
/*
=item C<static PMC * run_init_lib(PARROT_INTERP, void *handle, STRING *lib_name,
STRING *wo_ext)>
-Loads and Initializes a new library and returns a ParrotLibrary PMC.
-Takes the name of a library C<libname>, that is loaded with handle C<handle>.
-Calls the necessary initialization routines, if any.
+Loads and initializes a new library and returns a ParrotLibrary PMC. Takes the
+name of a library C<lib_name>, that is loaded with handle C<handle>. Calls the
+necessary initialization routines, if any.
=cut
@@ -520,6 +525,7 @@
return lib_pmc;
}
+
/*
=item C<static STRING * clone_string_into(Interp *d, Interp *s, PMC *value)>
@@ -538,9 +544,9 @@
clone_string_into(ARGMOD(Interp *d), ARGIN(Interp *s), ARGIN(PMC *value))
{
ASSERT_ARGS(clone_string_into)
- STRING * const orig = VTABLE_get_string(s, value);
- char * const raw_str = Parrot_str_to_cstring(s, orig);
- STRING * const ret =
+ STRING * const orig = VTABLE_get_string(s, value);
+ char * const raw_str = Parrot_str_to_cstring(s, orig);
+ STRING * const ret =
Parrot_str_new_init(d, raw_str, strlen(raw_str),
PARROT_DEFAULT_ENCODING, PARROT_DEFAULT_CHARSET,
PObj_constant_FLAG);
@@ -548,6 +554,7 @@
return ret;
}
+
/*
=item C<static PMC * make_string_pmc(PARROT_INTERP, STRING *string)>
@@ -570,6 +577,7 @@
return ret;
}
+
/*
=item C<PMC * Parrot_clone_lib_into(Interp *d, Interp *s, PMC *lib_pmc)>
@@ -608,7 +616,8 @@
* Anyways, if we hope to share bytecode at runtime, we need to have
* them have identical opcodes anyways.
*/
- PMC * const new_lib_pmc = Parrot_pmc_new_constant(d, enum_class_ParrotLibrary);
+ PMC * const new_lib_pmc = Parrot_pmc_new_constant(d,
+ enum_class_ParrotLibrary);
PMC_data(new_lib_pmc) = handle;
VTABLE_setprop(d, new_lib_pmc, CONST_STRING(s, "_filename"), make_string_pmc(d, wo_ext));
@@ -619,11 +628,13 @@
if (d->n_libs != s->n_libs) {
INTVAL i;
if (d->all_op_libs)
- d->all_op_libs = (op_lib_t **)mem_internal_realloc(d->all_op_libs,
- sizeof (op_lib_t *) * s->n_libs);
+ d->all_op_libs
+ = (op_lib_t **)mem_internal_realloc(d->all_op_libs,
+ sizeof (op_lib_t *) * s->n_libs);
else
- d->all_op_libs = (op_lib_t **)mem_internal_allocate(sizeof (op_lib_t *) *
- s->n_libs);
+ d->all_op_libs
+ = (op_lib_t **)mem_internal_allocate(sizeof (op_lib_t *) *
+ s->n_libs);
for (i = d->n_libs; i < s->n_libs; ++i)
d->all_op_libs[i] = s->all_op_libs[i];
d->n_libs = s->n_libs;
@@ -631,11 +642,11 @@
return new_lib_pmc;
}
- else {
- return run_init_lib(d, handle, lib_name, wo_ext);
- }
+
+ return run_init_lib(d, handle, lib_name, wo_ext);
}
+
/*
=item C<PMC * Parrot_load_lib(PARROT_INTERP, STRING *lib, PMC *parameters)>
@@ -682,9 +693,8 @@
*
* LOCK()
*/
- if (lib) {
+ if (lib)
lib_name = parrot_split_path_ext(interp, lib, &wo_ext, &ext);
- }
else {
wo_ext = CONST_STRING(interp, "");
lib_name = NULL;
@@ -692,27 +702,27 @@
}
lib_pmc = is_loaded(interp, wo_ext);
- if (!PMC_IS_NULL(lib_pmc)) {
- /* UNLOCK() */
+
+ /* UNLOCK() */
+ if (!PMC_IS_NULL(lib_pmc))
return lib_pmc;
- }
- if (!PMC_IS_NULL(parameters)) {
+ if (!PMC_IS_NULL(parameters))
flags = VTABLE_get_integer(interp, parameters);
- }
path = get_path(interp, lib, (Parrot_dlopen_flags)flags, &handle, wo_ext, ext);
- if (!path || !handle) {
- /*
- * XXX Parrot_ex_throw_from_c_args? return PMCNULL?
- * PMC Undef seems convenient, because it can be queried with get_bool()
- */
+
+ /*
+ * XXX Parrot_ex_throw_from_c_args? return PMCNULL?
+ * PMC Undef seems convenient, because it can be queried with get_bool()
+ */
+ if (!path || !handle)
return Parrot_pmc_new(interp, enum_class_Undef);
- }
return run_init_lib(interp, handle, lib_name, wo_ext);
}
+
/*
=back
Modified: branches/html_cleanup/src/dynoplibs/math.ops
==============================================================================
--- branches/html_cleanup/src/dynoplibs/math.ops Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/dynoplibs/math.ops Wed Sep 1 06:33:06 2010 (r48748)
@@ -95,8 +95,7 @@
result = VTABLE_get_integer(interp, $2) % $3;
- $1 = Parrot_pmc_new(interp, VTABLE_type(interp, $2));
- VTABLE_set_integer_native(interp, $1, result);
+ $1 = Parrot_pmc_new_init_int(interp, VTABLE_type(interp, $2), result);
}
inline op cmod(invar PMC, invar PMC, invar PMC) :base_core {
@@ -112,8 +111,7 @@
result = VTABLE_get_integer(interp, $2) % value;
- $1 = Parrot_pmc_new(interp, VTABLE_type(interp, $2));
- VTABLE_set_integer_native(interp, $1, result);
+ $1 = Parrot_pmc_new_init_int(interp, VTABLE_type(interp, $2), result);
}
########################################
@@ -173,8 +171,8 @@
result = fmod(VTABLE_get_integer(interp, $2), value);
- $1 = Parrot_pmc_new(interp, VTABLE_type(interp, $2));
- VTABLE_set_integer_native(interp, $1, (INTVAL) result);
+ $1 = Parrot_pmc_new_init_int(interp,
+ VTABLE_type(interp, $2), (INTVAL)result);
}
=back
Modified: branches/html_cleanup/src/gc/gc_ms.c
==============================================================================
--- branches/html_cleanup/src/gc/gc_ms.c Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/gc/gc_ms.c Wed Sep 1 06:33:06 2010 (r48748)
@@ -17,6 +17,8 @@
#include "parrot/parrot.h"
#include "gc_private.h"
+#define DEBUG_FREE_LIST 0
+
PARROT_DOES_NOT_RETURN
static void failed_allocation(unsigned int line, unsigned long size) /* HEADERIZER SKIP */
{
@@ -31,6 +33,13 @@
/* HEADERIZER BEGIN: static */
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
+PARROT_WARN_UNUSED_RESULT
+static INTVAL contained_in_attr_pool(
+ ARGIN(const PMC_Attribute_Pool *pool),
+ ARGIN(const void *ptr))
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+
static int gc_ms_active_sized_buffers(ARGIN(const Memory_Pools *mem_pools))
__attribute__nonnull__(1);
@@ -253,6 +262,9 @@
__attribute__nonnull__(2)
FUNC_MODIFIES(*mem_pools);
+#define ASSERT_ARGS_contained_in_attr_pool __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(pool) \
+ , PARROT_ASSERT_ARG(ptr))
#define ASSERT_ARGS_gc_ms_active_sized_buffers __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(mem_pools))
#define ASSERT_ARGS_gc_ms_add_free_object __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
@@ -984,6 +996,37 @@
/*
+=item C<static INTVAL contained_in_attr_pool(const PMC_Attribute_Pool *pool,
+const void *ptr)>
+
+Returns whether the given C<*ptr> points to a location in C<pool>.
+
+=cut
+
+*/
+
+PARROT_WARN_UNUSED_RESULT
+static INTVAL
+contained_in_attr_pool(ARGIN(const PMC_Attribute_Pool *pool), ARGIN(const void *ptr))
+{
+ ASSERT_ARGS(contained_in_attr_pool)
+ const PMC_Attribute_Arena *arena;
+ const ptrdiff_t item_space = pool->objects_per_alloc * pool->attr_size;
+
+ for (arena = pool->top_arena; arena; arena = arena->next) {
+ const ptrdiff_t ptr_diff = (const char *)ptr - (const char *)(arena + 1);
+
+ if (ptr_diff >= 0
+ && ptr_diff < item_space
+ && ptr_diff % pool->attr_size == 0)
+ return 1;
+ }
+
+ return 0;
+}
+
+/*
+
=item C<void gc_ms_free_pmc_attributes(PARROT_INTERP, PMC *pmc)>
Deallocates an attibutes structure from a PMC if it has the auto_attrs
@@ -1022,6 +1065,10 @@
ASSERT_ARGS(gc_ms_free_attributes_from_pool)
PMC_Attribute_Free_List * const item = (PMC_Attribute_Free_List *)data;
+#if DEBUG_FREE_LIST
+ PARROT_ASSERT(contained_in_attr_pool(pool, data));
+#endif
+
item->next = pool->free_list;
pool->free_list = item;
@@ -1540,6 +1587,10 @@
ASSERT_ARGS(gc_ms_add_free_object)
GC_MS_PObj_Wrapper *object = (GC_MS_PObj_Wrapper *)to_add;
+#if DEBUG_FREE_LIST
+ PARROT_ASSERT(contained_in_pool(pool, to_add));
+#endif
+
PObj_flags_SETTO(object, PObj_on_free_list_FLAG);
object->next_ptr = pool->free_list;
Modified: branches/html_cleanup/src/hash.c
==============================================================================
--- branches/html_cleanup/src/hash.c Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/hash.c Wed Sep 1 06:33:06 2010 (r48748)
@@ -25,30 +25,42 @@
*/
#include "parrot/parrot.h"
-#include "pmc/pmc_key.h"
/* the number of entries above which it's faster to hash the hashval instead of
* looping over the used HashBuckets directly */
-#define INITIAL_BUCKETS 8
+#define INITIAL_SIZE 8
/* HEADERIZER HFILE: include/parrot/hash.h */
/* HEADERIZER BEGIN: static */
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
+static void expand_hash(PARROT_INTERP, ARGMOD(Hash *hash))
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2)
+ FUNC_MODIFIES(*hash);
+
+PARROT_CANNOT_RETURN_NULL
+static PMC* get_integer_pmc(PARROT_INTERP, INTVAL value)
+ __attribute__nonnull__(1);
+
+PARROT_CANNOT_RETURN_NULL
+static PMC* get_number_pmc(PARROT_INTERP, FLOATVAL value)
+ __attribute__nonnull__(1);
+
+PARROT_CANNOT_RETURN_NULL
+static PMC * get_string_pmc(PARROT_INTERP, ARGIN(STRING *value))
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+
PARROT_WARN_UNUSED_RESULT
PARROT_PURE_FUNCTION
-static int cstring_compare(SHIM_INTERP,
+static int hash_compare_cstring(SHIM_INTERP,
ARGIN(const char *a),
ARGIN(const char *b))
__attribute__nonnull__(2)
__attribute__nonnull__(3);
-static void expand_hash(PARROT_INTERP, ARGMOD(Hash *hash))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- FUNC_MODIFIES(*hash);
-
PARROT_WARN_UNUSED_RESULT
PARROT_PURE_FUNCTION
static size_t key_hash_cstring(SHIM_INTERP,
@@ -75,18 +87,19 @@
__attribute__nonnull__(1)
__attribute__nonnull__(2);
-PARROT_WARN_UNUSED_RESULT
-PARROT_CONST_FUNCTION
-static int pointer_compare(SHIM_INTERP,
- ARGIN_NULLOK(const void *a),
- ARGIN_NULLOK(const void *b));
-
-#define ASSERT_ARGS_cstring_compare __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(a) \
- , PARROT_ASSERT_ARG(b))
#define ASSERT_ARGS_expand_hash __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(hash))
+#define ASSERT_ARGS_get_integer_pmc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(interp))
+#define ASSERT_ARGS_get_number_pmc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(interp))
+#define ASSERT_ARGS_get_string_pmc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(interp) \
+ , PARROT_ASSERT_ARG(value))
+#define ASSERT_ARGS_hash_compare_cstring __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(a) \
+ , PARROT_ASSERT_ARG(b))
#define ASSERT_ARGS_key_hash_cstring __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(value))
#define ASSERT_ARGS_key_hash_pointer __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
@@ -100,7 +113,6 @@
#define ASSERT_ARGS_parrot_mark_hash_values __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(hash))
-#define ASSERT_ARGS_pointer_compare __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
/* HEADERIZER END: static */
@@ -132,8 +144,8 @@
/*
-=item C<int STRING_compare(PARROT_INTERP, const void *search_key, const void
-*bucket_key)>
+=item C<int hash_compare_string(PARROT_INTERP, const void *search_key, const
+void *bucket_key)>
Compares the two strings, returning 0 if they are identical.
@@ -143,9 +155,10 @@
PARROT_WARN_UNUSED_RESULT
int
-STRING_compare(PARROT_INTERP, ARGIN(const void *search_key), ARGIN_NULLOK(const void *bucket_key))
+hash_compare_string(PARROT_INTERP, ARGIN(const void *search_key),
+ ARGIN_NULLOK(const void *bucket_key))
{
- ASSERT_ARGS(STRING_compare)
+ ASSERT_ARGS(hash_compare_string)
STRING const *s1 = (STRING const *)search_key;
STRING const *s2 = (STRING const *)bucket_key;
@@ -158,7 +171,7 @@
/*
-=item C<int STRING_compare_distinct_cs_enc(PARROT_INTERP, const void
+=item C<int hash_compare_string_distinct_enc(PARROT_INTERP, const void
*search_key, const void *bucket_key)>
Compare two strings. Returns 0 if they are identical. Considers differing
@@ -168,10 +181,10 @@
PARROT_WARN_UNUSED_RESULT
int
-STRING_compare_distinct_cs_enc(PARROT_INTERP, ARGIN(const void *search_key),
+hash_compare_string_distinct_enc(PARROT_INTERP, ARGIN(const void *search_key),
ARGIN(const void *bucket_key))
{
- ASSERT_ARGS(STRING_compare_distinct_cs_enc)
+ ASSERT_ARGS(hash_compare_string_distinct_enc)
STRING const *s1 = (STRING const *)search_key;
STRING const *s2 = (STRING const *)bucket_key;
@@ -181,13 +194,13 @@
return 1;
}
- return STRING_compare(interp, search_key, bucket_key);
+ return hash_compare_string(interp, search_key, bucket_key);
}
/*
-=item C<static int pointer_compare(PARROT_INTERP, const void *a, const void *b)>
+=item C<int hash_compare_pointer(PARROT_INTERP, const void *a, const void *b)>
Compares the two pointers, returning 0 if they are identical
@@ -197,10 +210,10 @@
PARROT_WARN_UNUSED_RESULT
PARROT_CONST_FUNCTION
-static int
-pointer_compare(SHIM_INTERP, ARGIN_NULLOK(const void *a), ARGIN_NULLOK(const void *b))
+int
+hash_compare_pointer(SHIM_INTERP, ARGIN_NULLOK(const void *a), ARGIN_NULLOK(const void *b))
{
- ASSERT_ARGS(pointer_compare)
+ ASSERT_ARGS(hash_compare_pointer)
return a != b;
}
@@ -262,7 +275,8 @@
/*
-=item C<static int cstring_compare(PARROT_INTERP, const char *a, const char *b)>
+=item C<static int hash_compare_cstring(PARROT_INTERP, const char *a, const char
+*b)>
Compares two C strings for equality, returning -1, 0, and 1 if the first string
is less than, equal to, or greater than the second, respectively.
@@ -274,9 +288,9 @@
PARROT_WARN_UNUSED_RESULT
PARROT_PURE_FUNCTION
static int
-cstring_compare(SHIM_INTERP, ARGIN(const char *a), ARGIN(const char *b))
+hash_compare_cstring(SHIM_INTERP, ARGIN(const char *a), ARGIN(const char *b))
{
- ASSERT_ARGS(cstring_compare)
+ ASSERT_ARGS(hash_compare_cstring)
return strcmp(a, b);
}
@@ -302,7 +316,7 @@
/*
-=item C<int PMC_compare(PARROT_INTERP, PMC *a, PMC *b)>
+=item C<int hash_compare_pmc(PARROT_INTERP, PMC *a, PMC *b)>
Compares two PMC for equality, returning 0 if the first is equal to second.
Uses void pointers to store the PMC, sadly.
@@ -314,9 +328,9 @@
PARROT_WARN_UNUSED_RESULT
PARROT_PURE_FUNCTION
int
-PMC_compare(PARROT_INTERP, ARGIN(PMC *a), ARGIN(PMC *b))
+hash_compare_pmc(PARROT_INTERP, ARGIN(PMC *a), ARGIN(PMC *b))
{
- ASSERT_ARGS(PMC_compare)
+ ASSERT_ARGS(hash_compare_pmc)
/* If pointers are same - PMCs are same */
if (a == b)
@@ -350,7 +364,7 @@
/*
-=item C<int int_compare(PARROT_INTERP, const void *a, const void *b)>
+=item C<int hash_compare_int(PARROT_INTERP, const void *a, const void *b)>
Compares two integers for equality, returning -1, 0, and 1 if the first is less
than, equal to, or greater than the second, respectively. Uses void pointers
@@ -363,9 +377,9 @@
PARROT_WARN_UNUSED_RESULT
PARROT_CONST_FUNCTION
int
-int_compare(SHIM_INTERP, ARGIN_NULLOK(const void *a), ARGIN_NULLOK(const void *b))
+hash_compare_int(SHIM_INTERP, ARGIN_NULLOK(const void *a), ARGIN_NULLOK(const void *b))
{
- ASSERT_ARGS(int_compare)
+ ASSERT_ARGS(hash_compare_int)
return a != b;
}
@@ -522,15 +536,15 @@
switch (key_type) {
case Hash_key_type_int:
key_fn = (hash_hash_key_fn)key_hash_int;
- cmp_fn = (hash_comp_fn)int_compare;
+ cmp_fn = (hash_comp_fn)hash_compare_int;
break;
case Hash_key_type_STRING:
key_fn = (hash_hash_key_fn)key_hash_STRING;
- cmp_fn = (hash_comp_fn)STRING_compare;
+ cmp_fn = (hash_comp_fn)hash_compare_string;
break;
case Hash_key_type_PMC:
key_fn = (hash_hash_key_fn)key_hash_PMC;
- cmp_fn = (hash_comp_fn)PMC_compare;
+ cmp_fn = (hash_comp_fn)hash_compare_pmc;
break;
default:
Parrot_ex_throw_from_c_args(interp, NULL, 1,
@@ -835,7 +849,7 @@
return parrot_create_hash(interp,
enum_type_PMC,
Hash_key_type_STRING,
- STRING_compare,
+ hash_compare_string,
(hash_hash_key_fn)key_hash_STRING);
}
@@ -859,7 +873,7 @@
return parrot_create_hash(interp,
enum_type_PMC,
Hash_key_type_cstring,
- (hash_comp_fn)cstring_compare,
+ (hash_comp_fn)hash_compare_cstring,
(hash_hash_key_fn)key_hash_cstring);
}
@@ -883,7 +897,7 @@
return parrot_create_hash(interp,
enum_type_ptr,
Hash_key_type_ptr,
- pointer_compare,
+ hash_compare_pointer,
key_hash_pointer);
}
@@ -910,7 +924,7 @@
return parrot_create_hash(interp,
enum_type_INTVAL,
Hash_key_type_int,
- int_compare,
+ hash_compare_int,
key_hash_int);
}
@@ -936,7 +950,7 @@
{
ASSERT_ARGS(parrot_create_hash)
return parrot_create_hash_sized(interp, val_type, hkey_type, compare, keyhash,
- INITIAL_BUCKETS);
+ INITIAL_SIZE);
}
@@ -982,7 +996,7 @@
NOTNULL(hash_comp_fn compare), NOTNULL(hash_hash_key_fn keyhash), UINTVAL size)
{
ASSERT_ARGS(parrot_create_hash_sized)
- UINTVAL initial_buckets = size > INITIAL_BUCKETS ? round_up_pow2(size) : INITIAL_BUCKETS;
+ UINTVAL initial_buckets = size > INITIAL_SIZE ? round_up_pow2(size) : INITIAL_SIZE;
HashBucket *bp;
void *alloc = Parrot_gc_allocate_memory_chunk_with_interior_pointers(
interp, sizeof (Hash) + HASH_ALLOC_SIZE(initial_buckets));
@@ -1086,14 +1100,9 @@
ASSERT_ARGS(parrot_chash_destroy_values)
UINTVAL i;
- for (i = 0; i <= hash->mask; ++i) {
- HashBucket *bucket = hash->index[i];
- while (bucket) {
- mem_gc_free(interp, bucket->key);
- func(bucket->value);
- bucket = bucket->next;
- }
- }
+ parrot_hash_iterate(hash,
+ mem_gc_free(interp, _bucket->key);
+ func(_bucket->value););
parrot_hash_destroy(interp, hash);
}
@@ -1148,7 +1157,7 @@
return NULL;
if (hash_val == (hash_hash_key_fn)key_hash_STRING
- && compare == STRING_compare) {
+ && compare == hash_compare_string) {
/* fast path for string keys */
DECL_CONST_CAST;
STRING * const s = (STRING *)PARROT_const_cast(void *, key);
@@ -1259,7 +1268,7 @@
const hash_comp_fn compare = hash->compare;
if (hash_val == (hash_hash_key_fn)key_hash_STRING
- && compare == STRING_compare) {
+ && compare == hash_compare_string) {
/* fast path for string keys */
STRING *s = (STRING *)key;
@@ -1427,7 +1436,7 @@
/*
-=item C<PMC* get_integer_pmc(PARROT_INTERP, INTVAL value)>
+=item C<static PMC* get_integer_pmc(PARROT_INTERP, INTVAL value)>
Lookup the PMC type which is used for storing native integers.
@@ -1436,7 +1445,7 @@
*/
PARROT_CANNOT_RETURN_NULL
-PMC*
+static PMC*
get_integer_pmc(PARROT_INTERP, INTVAL value)
{
ASSERT_ARGS(get_integer_pmc)
@@ -1448,7 +1457,7 @@
/*
-=item C<PMC* get_number_pmc(PARROT_INTERP, FLOATVAL value)>
+=item C<static PMC* get_number_pmc(PARROT_INTERP, FLOATVAL value)>
Lookup the PMC type which is used for floating point numbers.
@@ -1457,7 +1466,7 @@
*/
PARROT_CANNOT_RETURN_NULL
-PMC*
+static PMC*
get_number_pmc(PARROT_INTERP, FLOATVAL value)
{
ASSERT_ARGS(get_number_pmc)
@@ -1468,7 +1477,7 @@
/*
-=item C<PMC * get_string_pmc(PARROT_INTERP, STRING *value)>
+=item C<static PMC * get_string_pmc(PARROT_INTERP, STRING *value)>
Lookup the PMC type which is used for storing strings.
@@ -1477,7 +1486,7 @@
*/
PARROT_CANNOT_RETURN_NULL
-PMC *
+static PMC *
get_string_pmc(PARROT_INTERP, ARGIN(STRING *value))
{
ASSERT_ARGS(get_string_pmc)
Modified: branches/html_cleanup/src/multidispatch.c
==============================================================================
--- branches/html_cleanup/src/multidispatch.c Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/multidispatch.c Wed Sep 1 06:33:06 2010 (r48748)
@@ -963,7 +963,6 @@
ASSERT_ARGS(Parrot_mmd_add_multi_from_long_sig)
Parrot_Sub_attributes *sub;
STRING *sub_str = CONST_STRING(interp, "Sub");
- STRING *closure_str = CONST_STRING(interp, "Closure");
PMC *type_list = Parrot_str_split(interp, CONST_STRING(interp, ","), long_sig);
STRING *ns_name = VTABLE_get_string_keyed_int(interp, type_list, 0);
@@ -973,8 +972,7 @@
if (sub_obj->vtable->base_type == enum_class_NCI) {
SETATTR_NCI_multi_sig(interp, sub_obj, multi_sig);
}
- else if (VTABLE_isa(interp, sub_obj, sub_str)
- || VTABLE_isa(interp, sub_obj, closure_str)) {
+ else if (VTABLE_isa(interp, sub_obj, sub_str)) {
PMC_get_sub(interp, sub_obj, sub);
sub->multi_signature = multi_sig;
}
Modified: branches/html_cleanup/src/oo.c
==============================================================================
--- branches/html_cleanup/src/oo.c Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/oo.c Wed Sep 1 06:33:06 2010 (r48748)
@@ -50,15 +50,6 @@
__attribute__nonnull__(1)
__attribute__nonnull__(2);
-PARROT_WARN_UNUSED_RESULT
-PARROT_CAN_RETURN_NULL
-static PMC * find_method_direct_1(PARROT_INTERP,
- ARGIN(PMC *_class),
- ARGIN(STRING *method_name))
- __attribute__nonnull__(1)
- __attribute__nonnull__(2)
- __attribute__nonnull__(3);
-
PARROT_INLINE
PARROT_CANNOT_RETURN_NULL
PARROT_WARN_UNUSED_RESULT
@@ -81,10 +72,6 @@
#define ASSERT_ARGS_fail_if_type_exists __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(name))
-#define ASSERT_ARGS_find_method_direct_1 __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
- PARROT_ASSERT_ARG(interp) \
- , PARROT_ASSERT_ARG(_class) \
- , PARROT_ASSERT_ARG(method_name))
#define ASSERT_ARGS_get_pmc_proxy __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp))
#define ASSERT_ARGS_invalidate_all_caches __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
@@ -94,6 +81,63 @@
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
/* HEADERIZER END: static */
+
+/*
+
+=item C<static void debug_trace_find_meth(PARROT_INTERP, const PMC *_class,
+const STRING *name, const PMC *sub)>
+
+Print some information about the search for a sub.
+
+=cut
+
+*/
+
+#ifdef NDEBUG
+# define TRACE_FM(i, c, m, sub)
+#else
+# define TRACE_FM(i, c, m, sub) \
+ debug_trace_find_meth((i), (c), (m), (sub))
+
+static void
+debug_trace_find_meth(PARROT_INTERP, ARGIN(const PMC *_class),
+ ARGIN(const STRING *name), ARGIN_NULLOK(const PMC *sub))
+{
+ ASSERT_ARGS(debug_trace_find_meth)
+ STRING *class_name;
+ const char *result;
+ Interp *tracer;
+
+ if (!Interp_trace_TEST(interp, PARROT_TRACE_FIND_METH_FLAG))
+ return;
+
+ if (PObj_is_class_TEST(_class)) {
+ SLOTTYPE * const class_array = PMC_data_typed(_class, SLOTTYPE *);
+ PMC * const class_name_pmc = get_attrib_num(class_array, PCD_CLASS_NAME);
+ class_name = VTABLE_get_string(interp, class_name_pmc);
+ }
+ else
+ class_name = _class->vtable->whoami;
+
+ if (sub) {
+ if (sub->vtable->base_type == enum_class_NCI)
+ result = "NCI";
+ else
+ result = "Sub";
+ }
+ else
+ result = "no";
+
+ tracer = (interp->pdb && interp->pdb->debugger) ?
+ interp->pdb->debugger :
+ interp;
+ Parrot_io_eprintf(tracer, "# find_method class '%Ss' method '%Ss': %s\n",
+ class_name, name, result);
+}
+
+#endif
+
+
/*
=item C<void Parrot_oo_extract_methods_from_namespace(PARROT_INTERP, PMC *self,
@@ -870,15 +914,38 @@
Parrot_find_method_direct(PARROT_INTERP, ARGIN(PMC *_class), ARGIN(STRING *method_name))
{
ASSERT_ARGS(Parrot_find_method_direct)
- PMC * const found = find_method_direct_1(interp, _class, method_name);
- if (!PMC_IS_NULL(found))
- return found;
+ STRING * const class_str = CONST_STRING(interp, "class");
+ STRING * const methods_str = CONST_STRING(interp, "methods");
+ PMC * const mro = _class->vtable->mro;
+ const INTVAL n = VTABLE_elements(interp, mro);
+ INTVAL i;
+
+ for (i = 0; i < n; ++i) {
+ PMC * const _class = VTABLE_get_pmc_keyed_int(interp, mro, i);
+ PMC * const ns = VTABLE_get_namespace(interp, _class);
+ PMC * const class_obj = VTABLE_inspect_str(interp, ns, class_str);
+ PMC *method = PMCNULL;
+ PMC *method_hash;
+
+ if (PMC_IS_NULL(class_obj))
+ method_hash = VTABLE_inspect_str(interp, ns, methods_str);
+ else
+ method_hash = VTABLE_inspect_str(interp, class_obj, methods_str);
+
+ if (!PMC_IS_NULL(method_hash))
+ method = VTABLE_get_pmc_keyed_str(interp, method_hash, method_name);
+
+ if (PMC_IS_NULL(method))
+ method = VTABLE_get_pmc_keyed_str(interp, ns, method_name);
+ TRACE_FM(interp, _class, method_name, method);
- if (Parrot_str_equal(interp, method_name, CONST_STRING(interp, "__get_string")))
- return find_method_direct_1(interp, _class, CONST_STRING(interp, "__get_repr"));
+ if (!PMC_IS_NULL(method))
+ return method;
+ }
+ TRACE_FM(interp, _class, method_name, NULL);
return PMCNULL;
}
@@ -908,16 +975,14 @@
{
ASSERT_ARGS(Parrot_find_method_with_cache)
- UINTVAL type, bits;
- Caches *mc;
- Meth_cache_entry *e;
-
- PARROT_ASSERT(method_name != 0);
-
#if DISABLE_METH_CACHE
return Parrot_find_method_direct(interp, _class, method_name);
#else
+ Caches *mc;
+ Meth_cache_entry *e;
+ UINTVAL type, bits;
+
if (! PObj_constant_TEST(method_name))
return Parrot_find_method_direct(interp, _class, method_name);
@@ -926,31 +991,29 @@
bits = (((UINTVAL) Buffer_bufstart(method_name)) >> 2) & TBL_SIZE_MASK;
if (type >= mc->mc_size) {
- if (mc->idx) {
+ if (mc->idx)
mc->idx = mem_gc_realloc_n_typed_zeroed(interp, mc->idx,
- type + 1, mc->mc_size, Meth_cache_entry**);
- }
- else {
- mc->idx = mem_gc_allocate_n_zeroed_typed(interp, type + 1, Meth_cache_entry**);
- }
+ type + 1, mc->mc_size, Meth_cache_entry **);
+ else
+ mc->idx = mem_gc_allocate_n_zeroed_typed(interp, type + 1,
+ Meth_cache_entry **);
+
mc->mc_size = type + 1;
}
- if (mc->idx[type] == NULL) {
+ if (! mc->idx[type])
mc->idx[type] = mem_gc_allocate_n_zeroed_typed(interp,
- TBL_SIZE, Meth_cache_entry*);
- }
+ TBL_SIZE, Meth_cache_entry *);
- e = mc->idx[type][bits];
+ e = mc->idx[type][bits];
- while (e && e->strstart != Buffer_bufstart(method_name)) {
- e = e->next;
- }
+ while (e && e->strstart != Buffer_bufstart(method_name))
+ e = e->next;
if (!e) {
/* when here no or no correct entry was at [bits] */
/* Use zeroed allocation because find_method_direct can trigger GC */
- e = mem_gc_allocate_zeroed_typed(interp, Meth_cache_entry);
+ e = mem_gc_allocate_zeroed_typed(interp, Meth_cache_entry);
mc->idx[type][bits] = e;
@@ -967,116 +1030,6 @@
/*
-=item C<static void debug_trace_find_meth(PARROT_INTERP, const PMC *_class,
-const STRING *name, const PMC *sub)>
-
-Print some information about the search for a sub.
-
-=cut
-
-*/
-
-#ifdef NDEBUG
-# define TRACE_FM(i, c, m, sub)
-#else
-# define TRACE_FM(i, c, m, sub) \
- debug_trace_find_meth((i), (c), (m), (sub))
-
-static void
-debug_trace_find_meth(PARROT_INTERP, ARGIN(const PMC *_class),
- ARGIN(const STRING *name), ARGIN_NULLOK(const PMC *sub))
-{
- ASSERT_ARGS(debug_trace_find_meth)
- STRING *class_name;
- const char *result;
- Interp *tracer;
-
- if (!Interp_trace_TEST(interp, PARROT_TRACE_FIND_METH_FLAG))
- return;
-
- if (PObj_is_class_TEST(_class)) {
- SLOTTYPE * const class_array = PMC_data_typed(_class, SLOTTYPE *);
- PMC * const class_name_pmc = get_attrib_num(class_array, PCD_CLASS_NAME);
- class_name = VTABLE_get_string(interp, class_name_pmc);
- }
- else
- class_name = _class->vtable->whoami;
-
- if (sub) {
- if (sub->vtable->base_type == enum_class_NCI)
- result = "NCI";
- else
- result = "Sub";
- }
- else
- result = "no";
-
- tracer = (interp->pdb && interp->pdb->debugger) ?
- interp->pdb->debugger :
- interp;
- Parrot_io_eprintf(tracer, "# find_method class '%Ss' method '%Ss': %s\n",
- class_name, name, result);
-}
-
-#endif
-
-
-/*
-
-=item C<static PMC * find_method_direct_1(PARROT_INTERP, PMC *_class, STRING
-*method_name)>
-
-Find the method with the given name in the specified class.
-
-=cut
-
-*/
-
-PARROT_WARN_UNUSED_RESULT
-PARROT_CAN_RETURN_NULL
-static PMC *
-find_method_direct_1(PARROT_INTERP, ARGIN(PMC *_class),
- ARGIN(STRING *method_name))
-{
- ASSERT_ARGS(find_method_direct_1)
- INTVAL i;
-
- PMC * const mro = _class->vtable->mro;
- const INTVAL n = VTABLE_elements(interp, mro);
- STRING * const methods_str = CONST_STRING(interp, "methods");
- STRING * const class_str = CONST_STRING(interp, "class");
-
- for (i = 0; i < n; ++i) {
- PMC * const _class = VTABLE_get_pmc_keyed_int(interp, mro, i);
- PMC * const ns = VTABLE_get_namespace(interp, _class);
- PMC * const class_obj = VTABLE_inspect_str(interp, ns, class_str);
- PMC *method = PMCNULL;
- PMC * method_hash;
-
- if (PMC_IS_NULL(class_obj))
- method_hash = VTABLE_inspect_str(interp, ns, methods_str);
- else
- method_hash = VTABLE_inspect_str(interp, class_obj, methods_str);
-
- if (!PMC_IS_NULL(method_hash))
- method = VTABLE_get_pmc_keyed_str(interp, method_hash, method_name);
-
- if (PMC_IS_NULL(method))
- method = VTABLE_get_pmc_keyed_str(interp, ns, method_name);
-
- TRACE_FM(interp, _class, method_name, method);
-
- if (!PMC_IS_NULL(method))
- return method;
- }
-
- TRACE_FM(interp, _class, method_name, NULL);
- return PMCNULL;
-}
-
-
-/*
-
=item C<static PMC* C3_merge(PARROT_INTERP, PMC *merge_list)>
Merge together the MRO of the items in the list.
Modified: branches/html_cleanup/src/ops/core_ops.c
==============================================================================
--- branches/html_cleanup/src/ops/core_ops.c Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/ops/core_ops.c Wed Sep 1 06:33:06 2010 (r48748)
@@ -23778,13 +23778,8 @@
PMC * const result =
PMC_IS_NULL(lex_pad)
- ? NULL
+ ? PMCNULL
: VTABLE_get_pmc_keyed_str(interp, lex_pad, lex_name);
- if (!result) {
- opcode_t * const handler = Parrot_ex_throw_from_op_args(interp, NULL,
- EXCEPTION_LEX_NOT_FOUND,
- "Lexical '%Ss' not found", lex_name);return (opcode_t *)handler;
- }
PREG(1) = result;
return (opcode_t *)cur_opcode + 3;}
@@ -23798,13 +23793,8 @@
PMC * const result =
PMC_IS_NULL(lex_pad)
- ? NULL
+ ? PMCNULL
: VTABLE_get_pmc_keyed_str(interp, lex_pad, lex_name);
- if (!result) {
- opcode_t * const handler = Parrot_ex_throw_from_op_args(interp, NULL,
- EXCEPTION_LEX_NOT_FOUND,
- "Lexical '%Ss' not found", lex_name);return (opcode_t *)handler;
- }
PREG(1) = result;
return (opcode_t *)cur_opcode + 3;}
Modified: branches/html_cleanup/src/ops/var.ops
==============================================================================
--- branches/html_cleanup/src/ops/var.ops Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/ops/var.ops Wed Sep 1 06:33:06 2010 (r48748)
@@ -86,10 +86,8 @@
=item B<find_lex>(out PMC, in STR)
-Find the lexical variable named $2 and store it in $1. This
-opcode either throws an exception or returns a Null PMC for the failure case,
-depending on the implementation of the LexPad PMC. Parrot's
-standard LexPad throws an exception for non-existent names.
+Find the lexical variable named $2 and store it in $1. Return a
+Null PMC if the variable is not found.
=cut
@@ -100,14 +98,8 @@
PMC * const result =
PMC_IS_NULL(lex_pad)
- ? NULL
+ ? PMCNULL
: VTABLE_get_pmc_keyed_str(interp, lex_pad, lex_name);
- if (!result) {
- opcode_t * const handler = Parrot_ex_throw_from_op_args(interp, NULL,
- EXCEPTION_LEX_NOT_FOUND,
- "Lexical '%Ss' not found", lex_name);
- goto ADDRESS(handler);
- }
$1 = result;
}
@@ -455,9 +447,10 @@
=item B<find_name>(out PMC, in STR)
-Find the name $2 in lexical, current, global, or builtin namespace and
-store it in $1. If the name doesn't exist
-either throws an exception or sets $1 to PMCNULL, depending on current
+Find the name C<$2> in lexicals, then the current namespace, then the HLL
+root namespace, and finally Parrot builtins. These are checked in order
+and the first match is returned in C<$1>. If no matches are found,
+either throws an exception or sets C<$1> to PMCNULL, depending on current
errors settings. See B<errorson>.
=cut
Modified: branches/html_cleanup/src/packfile.c
==============================================================================
--- branches/html_cleanup/src/packfile.c Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/packfile.c Wed Sep 1 06:33:06 2010 (r48748)
@@ -2632,15 +2632,28 @@
mem_gc_free(interp, byte_code->op_func_table);
if (byte_code->op_info_table)
mem_gc_free(interp, byte_code->op_info_table);
- if (byte_code->op_mapping.libs)
+ if (byte_code->op_mapping.libs) {
+ opcode_t n_libs = byte_code->op_mapping.n_libs;
+ opcode_t i;
+
+ for (i = 0; i < n_libs; i++) {
+ mem_gc_free(interp, byte_code->op_mapping.libs[i].table_ops);
+ mem_gc_free(interp, byte_code->op_mapping.libs[i].lib_ops);
+ }
+
mem_gc_free(interp, byte_code->op_mapping.libs);
+ }
- byte_code->fixups = NULL;
+ if (byte_code->annotations)
+ PackFile_Annotations_destroy(interp, (PackFile_Segment *)byte_code->annotations);
+
+ byte_code->annotations = NULL;
byte_code->const_table = NULL;
byte_code->debugs = NULL;
- byte_code->op_mapping.libs = NULL;
+ byte_code->fixups = NULL;
byte_code->op_func_table = NULL;
byte_code->op_info_table = NULL;
+ byte_code->op_mapping.libs = NULL;
}
@@ -4299,6 +4312,10 @@
/* Free any entries. */
if (self->entries)
mem_gc_free(interp, self->entries);
+
+ self->keys = NULL;
+ self->groups = NULL;
+ self->entries = NULL;
}
@@ -4441,6 +4458,7 @@
self->num_entries = PF_fetch_opcode(seg->pf, &cursor);
self->entries = mem_gc_allocate_n_zeroed_typed(interp,
self->num_entries, PackFile_Annotations_Entry);
+
for (i = 0; i < self->num_entries; ++i) {
PackFile_Annotations_Entry * const entry = self->entries + i;
entry->bytecode_offset = PF_fetch_opcode(seg->pf, &cursor);
@@ -4637,11 +4655,11 @@
/* Add annotations entry. */
if (self->entries)
- self->entries = mem_gc_realloc_n_typed(interp, self->entries,
- 1 + self->num_entries, PackFile_Annotations_Entry);
- else
- self->entries = mem_gc_allocate_n_typed(interp,
- 1 + self->num_entries, PackFile_Annotations_Entry);
+ self->entries = mem_gc_realloc_n_typed(interp, self->entries,
+ 1 + self->num_entries, PackFile_Annotations_Entry);
+ else
+ self->entries = mem_gc_allocate_n_typed(interp,
+ 1 + self->num_entries, PackFile_Annotations_Entry);
self->entries[self->num_entries].bytecode_offset = offset;
self->entries[self->num_entries].key = key_id;
Modified: branches/html_cleanup/src/pbc_merge.c
==============================================================================
--- branches/html_cleanup/src/pbc_merge.c Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/pbc_merge.c Wed Sep 1 06:33:06 2010 (r48748)
@@ -648,11 +648,11 @@
/* op not yet mapped */
bc->op_count++;
bc->op_func_table =
- mem_gc_realloc_n_typed_zeroed(interp, bc->op_func_table, bc->op_count, bc->op_count,
+ mem_gc_realloc_n_typed_zeroed(interp, bc->op_func_table, bc->op_count, bc->op_count - 1,
op_func_t);
bc->op_func_table[bc->op_count - 1] = op_func;
bc->op_info_table =
- mem_gc_realloc_n_typed_zeroed(interp, bc->op_info_table, bc->op_count, bc->op_count,
+ mem_gc_realloc_n_typed_zeroed(interp, bc->op_info_table, bc->op_count, bc->op_count - 1,
op_info_t *);
bc->op_info_table[bc->op_count - 1] = info;
Modified: branches/html_cleanup/src/pmc/addrregistry.pmc
==============================================================================
--- branches/html_cleanup/src/pmc/addrregistry.pmc Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/pmc/addrregistry.pmc Wed Sep 1 06:33:06 2010 (r48748)
@@ -47,7 +47,7 @@
Hash *registry = parrot_create_hash(INTERP,
enum_type_int,
Hash_key_type_PMC,
- int_compare,
+ hash_compare_int,
key_hash_int);
SET_ATTR_hash(INTERP, SELF, registry);
Modified: branches/html_cleanup/src/pmc/bigint.pmc
==============================================================================
--- branches/html_cleanup/src/pmc/bigint.pmc Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/pmc/bigint.pmc Wed Sep 1 06:33:06 2010 (r48748)
@@ -1258,6 +1258,12 @@
PObj_custom_destroy_SET(SELF);
}
+ VTABLE void init_int(INTVAL iv) {
+ bigint_init(INTERP, SELF);
+ bigint_set_long(INTERP, SELF, (long)iv);
+ PObj_custom_destroy_SET(SELF);
+ }
+
VTABLE PMC *clone() {
PMC *res = Parrot_pmc_new(INTERP, SELF->vtable->base_type);
bigint_set(INTERP, res, SELF);
Modified: branches/html_cleanup/src/pmc/callcontext.pmc
==============================================================================
--- branches/html_cleanup/src/pmc/callcontext.pmc Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/pmc/callcontext.pmc Wed Sep 1 06:33:06 2010 (r48748)
@@ -208,7 +208,7 @@
GETATTR_CallContext_num_positionals(interp, self, num_positionals);
memcpy(new_array, array, num_positionals * sizeof (Pcc_cell));
- if (num_positionals > 8)
+ if (allocated_positionals > 8)
Parrot_gc_free_memory_chunk(interp, array);
else
Parrot_gc_free_fixed_size_storage(interp,
@@ -391,7 +391,7 @@
hash = parrot_create_hash(interp,
enum_type_ptr,
Hash_key_type_STRING,
- STRING_compare,
+ hash_compare_string,
(hash_hash_key_fn)key_hash_STRING);
SETATTR_CallContext_hash(interp, SELF, hash);
@@ -989,14 +989,14 @@
else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "handlers")))
GET_ATTR_handlers(INTERP, SELF, value);
else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "current_HLL"))) {
- /* This function from src/hash.c. */
- /* We probably have to move it to more suitable place */
GET_ATTR_current_HLL(INTERP, SELF, hll);
- value = get_integer_pmc(INTERP, hll);
+ value = Parrot_pmc_new(interp, Parrot_get_ctx_HLL_type(interp, enum_class_Integer));
+ VTABLE_set_integer_native(interp, value, hll);
}
else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "current_hll"))) {
GET_ATTR_current_HLL(INTERP, SELF, hll);
- value = get_string_pmc(INTERP, Parrot_get_HLL_name(INTERP, hll));
+ value = Parrot_pmc_new(interp, Parrot_get_ctx_HLL_type(interp, enum_class_String));
+ VTABLE_set_string_native(interp, value, Parrot_get_HLL_name(INTERP, hll));
}
else
Parrot_ex_throw_from_c_args(INTERP, NULL,
Modified: branches/html_cleanup/src/pmc/class.pmc
==============================================================================
--- branches/html_cleanup/src/pmc/class.pmc Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/pmc/class.pmc Wed Sep 1 06:33:06 2010 (r48748)
@@ -151,10 +151,6 @@
__attribute__nonnull__(1)
__attribute__nonnull__(2);
-static int pointer_compare(SHIM_INTERP,
- ARGIN_NULLOK(const void *a),
- ARGIN_NULLOK(const void *b));
-
#define ASSERT_ARGS_build_attrib_index __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(self))
@@ -183,28 +179,11 @@
#define ASSERT_ARGS_make_class_name __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp) \
, PARROT_ASSERT_ARG(SELF))
-#define ASSERT_ARGS_pointer_compare __attribute__unused__ int _ASSERT_ARGS_CHECK = (0)
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
/* HEADERIZER END: static */
/*
-=item C<static int pointer_compare(PARROT_INTERP, const void *a, const void *b)>
-
-=cut
-
-*/
-
-static int
-pointer_compare(SHIM_INTERP, ARGIN_NULLOK(const void *a),
- ARGIN_NULLOK(const void *b))
-{
- ASSERT_ARGS(pointer_compare)
- return a != b;
-}
-
-/*
-
=item C<static size_t key_hash_pointer(PARROT_INTERP, const void *value, size_t
seed)>
@@ -689,7 +668,7 @@
(Parrot_Class_attributes *) PMC_data(SELF);
/* Set flag for custom GC mark. */
- PObj_custom_mark_SET(SELF);
+ PObj_custom_mark_destroy_SETALL(SELF);
/* Set up the object. */
_class->name = CONST_STRING(INTERP, "");
@@ -708,7 +687,7 @@
_class->parent_overrides = Parrot_pmc_new(INTERP, enum_class_Hash);
_class->isa_cache = parrot_create_hash(INTERP,
enum_type_INTVAL, Hash_key_type_PMC,
- (hash_comp_fn)pointer_compare, (hash_hash_key_fn)key_hash_pointer);
+ (hash_comp_fn)hash_compare_pointer, (hash_hash_key_fn)key_hash_pointer);
/* We put ourself on the all parents list. */
VTABLE_push_pmc(INTERP, _class->all_parents, SELF);
Modified: branches/html_cleanup/src/pmc/exception.pmc
==============================================================================
--- branches/html_cleanup/src/pmc/exception.pmc Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/pmc/exception.pmc Wed Sep 1 06:33:06 2010 (r48748)
@@ -301,7 +301,7 @@
/*
-=item C<INTVAL get_integer_keyed(PMC *key)>
+=item C<INTVAL get_integer_keyed_str(STRING *key)>
Returns the integer value for C<*key>.
@@ -309,11 +309,9 @@
*/
- VTABLE INTVAL get_integer_keyed(PMC *key) {
- STRING * const name = VTABLE_get_string(INTERP, key);
- INTVAL result = 0;
-
- switch (getAttrEnum(INTERP, name)) {
+ VTABLE INTVAL get_integer_keyed_str(STRING *key) {
+ INTVAL result = 0;
+ switch (getAttrEnum(INTERP, key)) {
case attr_type:
GET_ATTR_type(INTERP, SELF, result);
break;
@@ -329,7 +327,7 @@
default:
/* If unknown attribute name, throw an exception. */
Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ATTRIB_NOT_FOUND,
- "No such integer attribute '%S'", name);
+ "No such integer attribute '%S'", key);
}
return result;
@@ -337,7 +335,7 @@
/*
-=item C<INTVAL get_integer_keyed_str(STRING *key)>
+=item C<INTVAL get_integer_keyed(PMC *key)>
Returns the integer value for C<*key>.
@@ -345,28 +343,9 @@
*/
- VTABLE INTVAL get_integer_keyed_str(STRING *key) {
- INTVAL result = 0;
- switch (getAttrEnum(INTERP, key)) {
- case attr_type:
- GET_ATTR_type(INTERP, SELF, result);
- break;
- case attr_severity:
- GET_ATTR_severity(INTERP, SELF, result);
- break;
- case attr_exit_code:
- GET_ATTR_exit_code(INTERP, SELF, result);
- break;
- case attr_handled:
- GET_ATTR_handled(INTERP, SELF, result);
- break;
- default:
- /* If unknown attribute name, throw an exception. */
- Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ATTRIB_NOT_FOUND,
- "No such integer attribute '%S'", key);
- }
-
- return result;
+ VTABLE INTVAL get_integer_keyed(PMC *key) {
+ STRING * const name = VTABLE_get_string(INTERP, key);
+ return SELF.get_integer_keyed_str(name);
}
/*
@@ -454,7 +433,7 @@
/*
-=item C<void set_integer_keyed(PMC *key, INTVAL value)>
+=item C<void set_integer_keyed_str(STRING *key, INTVAL value) >
Sets the integer value for C<*key>.
@@ -462,9 +441,8 @@
*/
- VTABLE void set_integer_keyed(PMC *key, INTVAL value) {
- STRING * const name = VTABLE_get_string(INTERP, key);
- switch (getAttrEnum(INTERP, name)) {
+ VTABLE void set_integer_keyed_str(STRING *key, INTVAL value) {
+ switch (getAttrEnum(INTERP, key)) {
case attr_type:
SET_ATTR_type(INTERP, SELF, value);
break;
@@ -480,13 +458,13 @@
default:
/* If unknown attribute name, throw an exception. */
Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ATTRIB_NOT_FOUND,
- "No such integer attribute '%S'", name);
+ "No such integer attribute '%S'", key);
}
}
/*
-=item C<void set_integer_keyed_str(STRING *key, INTVAL value) >
+=item C<void set_integer_keyed(PMC *key, INTVAL value)>
Sets the integer value for C<*key>.
@@ -494,25 +472,9 @@
*/
- VTABLE void set_integer_keyed_str(STRING *key, INTVAL value) {
- switch (getAttrEnum(INTERP, key)) {
- case attr_type:
- SET_ATTR_type(INTERP, SELF, value);
- break;
- case attr_severity:
- SET_ATTR_severity(INTERP, SELF, value);
- break;
- case attr_exit_code:
- SET_ATTR_exit_code(INTERP, SELF, value);
- break;
- case attr_handled:
- SET_ATTR_handled(INTERP, SELF, value);
- break;
- default:
- /* If unknown attribute name, throw an exception. */
- Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ATTRIB_NOT_FOUND,
- "No such integer attribute '%S'", key);
- }
+ VTABLE void set_integer_keyed(PMC *key, INTVAL value) {
+ STRING * const name = VTABLE_get_string(INTERP, key);
+ SELF.set_integer_keyed_str(name, value);
}
/*
@@ -628,6 +590,7 @@
GET_ATTR_exit_code(INTERP, SELF, exit_code);
value = Parrot_pmc_new_init_int(INTERP, enum_class_Integer, exit_code);
}
+ break;
case attr_handled:
{
INTVAL handled;
@@ -824,6 +787,7 @@
*/
METHOD backtrace() {
+ STRING * const meth_backtrace = CONST_STRING(INTERP, "backtrace");
PMC *result = PMCNULL;
PMC *resume;
@@ -832,7 +796,8 @@
if (!PMC_IS_NULL(resume)) {
/* We have a resume continuation, so we can get the address from that. */
const Parrot_Continuation_attributes * const cont = PARROT_CONTINUATION(resume);
- Parrot_pcc_invoke_method_from_c_args(INTERP, cont->to_ctx, CONST_STRING(INTERP, "backtrace"), "P->P", resume, &result);
+ Parrot_pcc_invoke_method_from_c_args(INTERP, cont->to_ctx, meth_backtrace,
+ "P->P", resume, &result);
}
else {
/* Hopefully we have a thrower set - our most epic fail fallback is
@@ -841,7 +806,8 @@
GET_ATTR_thrower(INTERP, SELF, cur_ctx);
if (PMC_IS_NULL(cur_ctx))
cur_ctx = CURRENT_CONTEXT(INTERP);
- Parrot_pcc_invoke_method_from_c_args(INTERP, cur_ctx, CONST_STRING(INTERP, "backtrace"), "->P", &result);
+ Parrot_pcc_invoke_method_from_c_args(INTERP, cur_ctx, meth_backtrace,
+ "->P", &result);
}
RETURN(PMC *result);
Modified: branches/html_cleanup/src/pmc/hash.pmc
==============================================================================
--- branches/html_cleanup/src/pmc/hash.pmc Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/pmc/hash.pmc Wed Sep 1 06:33:06 2010 (r48748)
@@ -50,8 +50,62 @@
/* HEADERIZER HFILE: none */
/* HEADERIZER BEGIN: static */
+/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
+
+PARROT_CANNOT_RETURN_NULL
+PARROT_WARN_UNUSED_RESULT
+static PMC* get_next_hash(PARROT_INTERP,
+ ARGMOD(Hash *hash),
+ ARGIN(void *key))
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2)
+ __attribute__nonnull__(3)
+ FUNC_MODIFIES(*hash);
+
+#define ASSERT_ARGS_get_next_hash __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
+ PARROT_ASSERT_ARG(interp) \
+ , PARROT_ASSERT_ARG(hash) \
+ , PARROT_ASSERT_ARG(key))
+/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
/* HEADERIZER END: static */
+/*
+
+=item C<static PMC* get_next_hash(PARROT_INTERP, Hash *hash, void *key)>
+
+Get the next hash for multipart keys. Autovivify a hash if it doesn't exist.
+
+=cut
+
+*/
+
+PARROT_CANNOT_RETURN_NULL
+PARROT_WARN_UNUSED_RESULT
+static PMC*
+get_next_hash(PARROT_INTERP, ARGMOD(Hash *hash), ARGIN(void *key))
+{
+ ASSERT_ARGS(get_next_hash)
+ PMC *next_hash;
+ HashBucket *bucket;
+
+ if (hash->entry_type != enum_type_PMC)
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Hash entry type must be PMC for multipart keys.");
+
+ bucket = parrot_hash_get_bucket(interp, hash, key);
+
+ if (bucket) {
+ next_hash = (PMC *)bucket->value;
+ }
+ else {
+ /* autovivify a Hash */
+ next_hash = Parrot_pmc_new(interp, enum_class_Hash);
+ parrot_hash_put(interp, hash, key, next_hash);
+ }
+
+ return next_hash;
+}
+
pmclass Hash provides hash auto_attrs {
ATTR Hash *hash;
@@ -88,7 +142,7 @@
attr->hash = parrot_create_hash(INTERP,
(PARROT_DATA_TYPE)value_type,
Hash_key_type_STRING,
- STRING_compare,
+ hash_compare_string,
(hash_hash_key_fn)key_hash_STRING);
PObj_custom_mark_destroy_SETALL(SELF);
}
@@ -98,6 +152,7 @@
if (hash)
parrot_hash_destroy(INTERP, hash);
}
+
/*
=item C<void mark()>
@@ -179,21 +234,21 @@
new_hash = parrot_create_hash(INTERP,
entry_type,
Hash_key_type_STRING,
- STRING_compare,
+ hash_compare_string,
(hash_hash_key_fn)key_hash_STRING);
else if (type == Hash_key_type_int)
/* new_int_hash set BOTH keys and values to INTVAL */
new_hash = parrot_create_hash(INTERP,
entry_type,
Hash_key_type_int,
- int_compare,
+ hash_compare_int,
key_hash_int);
else if (type == Hash_key_type_PMC)
/* new_int_hash set BOTH keys and values to INTVAL */
new_hash = parrot_create_hash(INTERP,
entry_type,
Hash_key_type_PMC,
- (hash_comp_fn)PMC_compare,
+ (hash_comp_fn)hash_compare_pmc,
(hash_hash_key_fn)key_hash_PMC);
else
/* We probably will not implement other types of keys. They are way
@@ -243,9 +298,9 @@
/*
If someone called Hash.set_pointer with NULL pointer...
- It will create STRING* keys hash. Because we can't use STRING_compare
- directly - it declared static in F<src/hash.c>
+ It will create STRING* keys hash.
*/
+
if (old_hash && old_hash->entry_type == type)
return;
@@ -256,7 +311,7 @@
new_hash = parrot_create_hash(INTERP,
(PARROT_DATA_TYPE)type,
old_hash ? old_hash->key_type : Hash_key_type_STRING,
- old_hash ? old_hash->compare : STRING_compare,
+ old_hash ? old_hash->compare : hash_compare_string,
old_hash ? old_hash->hash_val : (hash_hash_key_fn)key_hash_STRING);
break;
default:
@@ -416,24 +471,25 @@
/* Handling Keys */
VTABLE INTVAL get_integer_keyed(PMC *key) {
- const Hash * const hash = (Hash *)SELF.get_pointer();
- HashBucket * const b = parrot_hash_get_bucket(INTERP, hash,
- hash_key_from_pmc(INTERP, hash, key));
- PMC *valpmc;
- PMC *nextkey;
+ const Hash * const hash = (Hash *)SELF.get_pointer();
+ const void * const hash_key = hash_key_from_pmc(INTERP, hash, key);
+ HashBucket * const b = parrot_hash_get_bucket(INTERP, hash, hash_key);
if (!b)
return 0;
- nextkey = key_next(INTERP, key);
- valpmc = hash_value_to_pmc(INTERP, hash, b->value);
+ key = key_next(INTERP, key);
/* Stop recursion. This is last step */
- if (!nextkey)
- return VTABLE_get_integer(INTERP, valpmc);
+ if (!key)
+ return hash_value_to_int(INTERP, hash, b->value);
+
+ if (hash->entry_type != enum_type_PMC)
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Hash entry type must be PMC for multipart keys.");
- /* Recusively call to enclosed aggregate */
- return VTABLE_get_integer_keyed(INTERP, valpmc, nextkey);
+ /* Recursively call to enclosed aggregate */
+ return VTABLE_get_integer_keyed(INTERP, (PMC *)b->value, key);
}
/*
@@ -445,11 +501,8 @@
*/
VTABLE void set_integer_keyed(PMC *key, INTVAL value) {
- Hash * const hash = (Hash *)SELF.get_pointer();
- void * const keystr = hash_key_from_pmc(INTERP, hash, key);
- PMC * const nextkey = key_next(INTERP, key);
- PMC *box;
- HashBucket *b;
+ Hash * const hash = (Hash *)SELF.get_pointer();
+ void * const hash_key = hash_key_from_pmc(INTERP, hash, key);
if (PObj_constant_TEST(SELF)
&& !PObj_constant_TEST((PObj *)key))
@@ -457,23 +510,16 @@
EXCEPTION_INVALID_OPERATION,
"Used non-constant PMC key in constant hash.");
- if (!nextkey) {
- parrot_hash_put(INTERP, hash, keystr,
+ key = key_next(INTERP, key);
+
+ if (!key) {
+ parrot_hash_put(INTERP, hash, hash_key,
hash_value_from_int(INTERP, hash, value));
- return;
}
-
- b = parrot_hash_get_bucket(INTERP, hash, keystr);
- if (b)
- box = hash_value_to_pmc(INTERP, hash, b->value);
else {
- /* autovivify an Hash */
- box = Parrot_pmc_new(INTERP, SELF.type());
- parrot_hash_put(INTERP, hash, keystr,
- hash_value_from_pmc(INTERP, hash, box));
+ PMC * const next_hash = get_next_hash(INTERP, hash, hash_key);
+ VTABLE_set_integer_keyed(INTERP, next_hash, key, value);
}
-
- VTABLE_set_integer_keyed(INTERP, box, nextkey, value);
}
VTABLE void set_integer_keyed_int(INTVAL key, INTVAL value) {
@@ -547,22 +593,23 @@
/* I can't migrate this function right now. Some problem with JITting */
VTABLE FLOATVAL get_number_keyed(PMC *key) {
- PMC *nextkey;
- PMC *valpmc;
- const Hash * const hash = (Hash *)SELF.get_pointer();
- void * const keystr = hash_key_from_pmc(INTERP, hash, key);
- HashBucket * const b = parrot_hash_get_bucket(INTERP, hash, keystr);
+ const Hash * const hash = (Hash *)SELF.get_pointer();
+ void * const hash_key = hash_key_from_pmc(INTERP, hash, key);
+ HashBucket * const b = parrot_hash_get_bucket(INTERP, hash, hash_key);
if (!b)
return 0.0;
- nextkey = key_next(INTERP, key);
- valpmc = hash_value_to_pmc(INTERP, hash, b->value);
+ key = key_next(INTERP, key);
+
+ if (!key)
+ return hash_value_to_number(INTERP, hash, b->value);
- if (!nextkey)
- return VTABLE_get_number(INTERP, valpmc);
+ if (hash->entry_type != enum_type_PMC)
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Hash entry type must be PMC for multipart keys.");
- return VTABLE_get_number_keyed(INTERP, valpmc, nextkey);
+ return VTABLE_get_number_keyed(INTERP, (PMC *)b->value, key);
}
@@ -609,24 +656,25 @@
*/
VTABLE STRING *get_string_keyed(PMC *key) {
- const Hash * const hash = (Hash *)SELF.get_pointer();
- HashBucket * const b = parrot_hash_get_bucket(INTERP, hash,
- hash_key_from_pmc(INTERP, hash, key));
- PMC *valpmc;
- PMC *nextkey;
+ const Hash * const hash = (Hash *)SELF.get_pointer();
+ const void * const hash_key = hash_key_from_pmc(INTERP, hash, key);
+ HashBucket * const b = parrot_hash_get_bucket(INTERP, hash, hash_key);
if (!b)
return Parrot_str_new_noinit(INTERP, enum_stringrep_one, 0);
- nextkey = key_next(INTERP, key);
- valpmc = hash_value_to_pmc(INTERP, hash, b->value);
+ key = key_next(INTERP, key);
/* Stop recursion. This is last step */
- if (!nextkey)
- return VTABLE_get_string(INTERP, valpmc);
+ if (!key)
+ return hash_value_to_string(INTERP, hash, b->value);
+
+ if (hash->entry_type != enum_type_PMC)
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Hash entry type must be PMC for multipart keys.");
- /* Recusively call to enclosed aggregate */
- return VTABLE_get_string_keyed(INTERP, valpmc, nextkey);
+ /* Recursively call to enclosed aggregate */
+ return VTABLE_get_string_keyed(INTERP, (PMC *)b->value, key);
}
/*
@@ -638,11 +686,8 @@
*/
VTABLE void set_string_keyed(PMC *key, STRING *value) {
- Hash * const hash = (Hash *)SELF.get_pointer();
- void * const keystr = hash_key_from_pmc(INTERP, hash, key);
- PMC * const nextkey = key_next(INTERP, key);
- PMC *box;
- HashBucket *b;
+ Hash * const hash = (Hash *)SELF.get_pointer();
+ void * const hash_key = hash_key_from_pmc(INTERP, hash, key);
if (PObj_constant_TEST(SELF)){
if (!PObj_constant_TEST((PObj *)key))
@@ -655,23 +700,16 @@
"Used non-constant STRING value in constant hash.");
}
- if (!nextkey) {
- parrot_hash_put(INTERP, hash, keystr,
+ key = key_next(INTERP, key);
+
+ if (!key) {
+ parrot_hash_put(INTERP, hash, hash_key,
hash_value_from_string(INTERP, hash, value));
- return;
}
-
- b = parrot_hash_get_bucket(INTERP, hash, keystr);
- if (b)
- box = hash_value_to_pmc(INTERP, hash, b->value);
else {
- /* autovivify an Hash */
- box = Parrot_pmc_new(INTERP, SELF.type());
- parrot_hash_put(INTERP, hash, keystr,
- hash_value_from_pmc(INTERP, hash, box));
+ PMC * const next_hash = get_next_hash(INTERP, hash, hash_key);
+ VTABLE_set_string_keyed(INTERP, next_hash, key, value);
}
-
- VTABLE_set_string_keyed(INTERP, box, nextkey, value);
}
/*
@@ -696,8 +734,7 @@
"Used non-constant STRING value in constant hash.");
}
- parrot_hash_put(INTERP, hash,
- hash_key_from_string(INTERP, hash, key),
+ parrot_hash_put(INTERP, hash, hash_key_from_string(INTERP, hash, key),
hash_value_from_string(INTERP, hash, value));
}
@@ -731,14 +768,13 @@
VTABLE PMC *get_pmc_keyed_str(STRING *key) {
const Hash *hash;
- HashBucket *b = NULL;
+ HashBucket *b;
GET_ATTR_hash(INTERP, SELF, hash);
/* special case the most likely key type, for speed */
- key = hash->key_type == Hash_key_type_STRING
- ? key
- : (STRING *)hash_key_from_string(INTERP, hash, key);
+ if (hash->key_type != Hash_key_type_STRING)
+ key = (STRING *)hash_key_from_string(INTERP, hash, key);
b = parrot_hash_get_bucket(INTERP, hash, key);
@@ -765,24 +801,25 @@
/* Compound Key */
VTABLE PMC *get_pmc_keyed(PMC *key) {
- const Hash * const hash = (Hash *)SELF.get_pointer();
- HashBucket * const b = parrot_hash_get_bucket(INTERP, hash,
- hash_key_from_pmc(INTERP, hash, key));
- PMC *valpmc;
- PMC *nextkey;
+ const Hash * const hash = (Hash *)SELF.get_pointer();
+ const void * const hash_key = hash_key_from_pmc(INTERP, hash, key);
+ HashBucket * const b = parrot_hash_get_bucket(INTERP, hash, hash_key);
if (!b)
return PMCNULL;
- nextkey = key_next(INTERP, key);
- valpmc = hash_value_to_pmc(INTERP, hash, b->value);
+ key = key_next(INTERP, key);
/* Stop recursion. This is last step */
- if (!nextkey)
- return valpmc;
+ if (!key)
+ return hash_value_to_pmc(INTERP, hash, b->value);
- /* Recusively call to enclosed aggregate */
- return VTABLE_get_pmc_keyed(INTERP, valpmc, nextkey);
+ if (hash->entry_type != enum_type_PMC)
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+ "Hash entry type must be PMC for multipart keys.");
+
+ /* Recursively call to enclosed aggregate */
+ return VTABLE_get_pmc_keyed(INTERP, (PMC *)b->value, key);
}
/*
@@ -794,11 +831,8 @@
*/
VTABLE void set_number_keyed(PMC *key, FLOATVAL value) {
- Hash * const hash = (Hash *)SELF.get_pointer();
- void * const keystr = hash_key_from_pmc(INTERP, hash, key);
- PMC * const nextkey = key_next(INTERP, key);
- PMC *box = PMCNULL;
- HashBucket *b;
+ Hash * const hash = (Hash *)SELF.get_pointer();
+ void * const hash_key = hash_key_from_pmc(INTERP, hash, key);
if (PObj_constant_TEST(SELF)
&& !PObj_constant_TEST((PObj *)key))
@@ -806,21 +840,16 @@
EXCEPTION_INVALID_OPERATION,
"Used non-constant PMC key in constant hash.");
- if (!nextkey) {
- PMC * const val = get_number_pmc(INTERP, value);
- parrot_hash_put(INTERP, hash, keystr, hash_value_from_pmc(INTERP, hash, val));
- return;
- }
-
- b = parrot_hash_get_bucket(INTERP, (Hash *)SELF.get_pointer(), keystr);
- if (b)
- box = hash_value_to_pmc(INTERP, hash, b->value);
-
- /* autovivify an Hash */
- if (PMC_IS_NULL(box))
- box = Parrot_pmc_new(INTERP, SELF.type());
+ key = key_next(INTERP, key);
- VTABLE_set_number_keyed(INTERP, box, nextkey, value);
+ if (!key) {
+ parrot_hash_put(INTERP, hash, hash_key,
+ hash_value_from_number(INTERP, hash, value));
+ }
+ else {
+ PMC * const next_hash = get_next_hash(INTERP, hash, hash_key);
+ VTABLE_set_number_keyed(INTERP, next_hash, key, value);
+ }
}
/*
@@ -834,7 +863,7 @@
*/
VTABLE void set_number_keyed_str(STRING *key, FLOATVAL value) {
- PMC * const val = get_number_pmc(INTERP, value);
+ Hash * const hash = (Hash *)SELF.get_pointer();
if (PObj_constant_TEST(SELF)
&& !PObj_constant_TEST((PObj *)key))
@@ -842,7 +871,8 @@
EXCEPTION_INVALID_OPERATION,
"Used non-constant STRING key in constant hash.");
- parrot_hash_put(INTERP, (Hash *)SELF.get_pointer(), key, val);
+ parrot_hash_put(INTERP, hash, hash_key_from_string(INTERP, hash, key),
+ hash_value_from_number(INTERP, hash, value));
}
/*
@@ -854,11 +884,8 @@
*/
VTABLE void set_pmc_keyed(PMC *key, PMC *value) {
- Hash * const hash = (Hash *)SELF.get_pointer();
- void * const keystr = hash_key_from_pmc(INTERP, hash, key);
- PMC * const nextkey = key_next(INTERP, key);
- PMC *box;
- HashBucket *b;
+ Hash * const hash = (Hash *)SELF.get_pointer();
+ void * const hash_key = hash_key_from_pmc(INTERP, hash, key);
if (PObj_constant_TEST(SELF)) {
if (!PObj_constant_TEST((PObj *)key))
@@ -872,23 +899,15 @@
"Used non-constant PMC value in constant hash.");
}
- if (!nextkey) {
- parrot_hash_put(INTERP, hash, keystr, value);
- return;
- }
+ key = key_next(INTERP, key);
- b = parrot_hash_get_bucket(INTERP, hash, keystr);
- if (b)
- box = hash_value_to_pmc(INTERP, hash, b->value);
+ if (!key) {
+ parrot_hash_put(INTERP, hash, hash_key, value);
+ }
else {
- /* autovivify an Hash */
- box = Parrot_pmc_new(INTERP, SELF.type());
- parrot_hash_put(INTERP, hash, keystr,
- hash_value_from_pmc(INTERP, hash, box));
+ PMC * const next_hash = get_next_hash(INTERP, hash, hash_key);
+ VTABLE_set_pmc_keyed(INTERP, next_hash, key, value);
}
-
-
- VTABLE_set_pmc_keyed(INTERP, box, nextkey, value);
}
/*
@@ -960,7 +979,12 @@
if (!key)
return 1;
- return VTABLE_exists_keyed(INTERP, hash_value_to_pmc(INTERP, h, b->value), key);
+ if (h->entry_type != enum_type_PMC)
+ Parrot_ex_throw_from_c_args(INTERP, NULL,
+ EXCEPTION_INVALID_OPERATION,
+ "Hash entry type must be PMC for multipart keys.");
+
+ return VTABLE_exists_keyed(INTERP, (PMC *)b->value, key);
}
/*
@@ -1006,9 +1030,13 @@
if (!key)
return VTABLE_defined(INTERP, hash_value_to_pmc(INTERP, h, b->value));
- else
- return VTABLE_defined_keyed(INTERP,
- hash_value_to_pmc(INTERP, h, b->value), key);
+
+ if (h->entry_type != enum_type_PMC)
+ Parrot_ex_throw_from_c_args(INTERP, NULL,
+ EXCEPTION_INVALID_OPERATION,
+ "Hash entry type must be PMC for multipart keys.");
+
+ return VTABLE_defined_keyed(INTERP, (PMC *)b->value, key);
}
/*
@@ -1045,10 +1073,17 @@
key = key_next(INTERP, key);
- if (!key)
+ if (!key) {
parrot_hash_delete(INTERP, h, sx);
- else
- VTABLE_delete_keyed(INTERP, (PMC *)b->value, key);
+ return;
+ }
+
+ if (h->entry_type != enum_type_PMC)
+ Parrot_ex_throw_from_c_args(INTERP, NULL,
+ EXCEPTION_INVALID_OPERATION,
+ "Hash entry type must be PMC for multipart keys.");
+
+ VTABLE_delete_keyed(INTERP, (PMC *)b->value, key);
}
/*
Modified: branches/html_cleanup/src/pmc/imageiostrings.pmc
==============================================================================
--- branches/html_cleanup/src/pmc/imageiostrings.pmc Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/pmc/imageiostrings.pmc Wed Sep 1 06:33:06 2010 (r48748)
@@ -50,6 +50,8 @@
parrot_new_intval_hash(INTERP));
PARROT_IMAGEIOSTRINGS(SELF)->list = Parrot_pmc_new(INTERP, enum_class_ResizableStringArray);
+
+ PObj_custom_mark_SET(SELF);
}
/*
Modified: branches/html_cleanup/src/pmc/integer.pmc
==============================================================================
--- branches/html_cleanup/src/pmc/integer.pmc Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/pmc/integer.pmc Wed Sep 1 06:33:06 2010 (r48748)
@@ -141,9 +141,8 @@
*/
VTABLE PMC *clone() {
- PMC * const clone = Parrot_pmc_new(INTERP, SELF->vtable->base_type);
- VTABLE_set_integer_native(INTERP, clone, SELF.get_integer());
- return clone;
+ return Parrot_pmc_new_init_int(INTERP, SELF->vtable->base_type,
+ SELF.get_integer());
}
/*
@@ -321,18 +320,13 @@
const INTVAL b = VTABLE_get_integer(INTERP, value);
const INTVAL c = a + b;
- if ((c^a) >= 0 || (c^b) >= 0) {
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
- /* need this for e.g. Undef PMC */
- VTABLE_set_integer_native(INTERP, dest, c);
- return dest;
- }
+ if ((c^a) >= 0 || (c^b) >= 0)
+ return Parrot_pmc_new_init_int(INTERP,
+ VTABLE_type(INTERP, SELF), c);
else {
- PMC * temp;
+ PMC *temp;
maybe_throw_overflow_error(INTERP);
- temp = Parrot_pmc_new(INTERP, enum_class_BigInt);
- VTABLE_set_integer_native(INTERP, temp, a);
+ temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, a);
return VTABLE_add(INTERP, temp, value, dest);
}
}
@@ -340,10 +334,9 @@
MULTI PMC *add(Complex value, PMC *dest) {
const INTVAL a = SELF.get_integer();
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, value));
-
- VTABLE_set_number_native(INTERP, dest,
- a + VTABLE_get_number_keyed_int(INTERP, value, 0));
+ dest = Parrot_pmc_new_init_int(INTERP,
+ VTABLE_type(INTERP, value),
+ a + VTABLE_get_number_keyed_int(INTERP, value, 0));
VTABLE_set_number_keyed_int(INTERP, dest, 1,
VTABLE_get_number_keyed_int(INTERP, value, 1));
@@ -354,17 +347,16 @@
MULTI PMC *add(BigInt value, PMC *dest) {
PMC *temp;
maybe_throw_overflow_error(INTERP);
- temp = Parrot_pmc_new(INTERP, enum_class_BigInt);
- VTABLE_set_integer_native(INTERP, temp, SELF.get_integer());
+ temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt,
+ SELF.get_integer());
return VTABLE_add(INTERP, temp, value, dest);
}
MULTI PMC *add(DEFAULT value, PMC *dest) {
dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, value));
-
VTABLE_set_number_native(INTERP, dest,
- SELF.get_integer() + VTABLE_get_number(INTERP, value));
+ SELF.get_integer() + VTABLE_get_number(interp, value));
return dest;
}
@@ -373,17 +365,13 @@
const INTVAL a = VTABLE_get_integer(INTERP, SELF);
const INTVAL c = a + b;
- if ((c^a) >= 0 || (c^b) >= 0) {
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
- VTABLE_set_integer_native(INTERP, dest, c);
- return dest;
- }
+ if ((c^a) >= 0 || (c^b) >= 0)
+ return Parrot_pmc_new_init_int(INTERP,
+ VTABLE_type(INTERP, SELF), c);
else {
PMC *temp;
maybe_throw_overflow_error(INTERP);
- temp = Parrot_pmc_new(INTERP, enum_class_BigInt);
- VTABLE_set_integer_native(INTERP, temp, a);
+ temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, a);
return VTABLE_add_int(INTERP, temp, b, dest);
}
}
@@ -463,17 +451,13 @@
const INTVAL b = VTABLE_get_integer(INTERP, value);
const INTVAL c = a - b;
- if ((c^a) >= 0 || (c^~b) >= 0) {
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
- VTABLE_set_integer_native(INTERP, dest, c);
- return dest;
- }
+ if ((c^a) >= 0 || (c^~b) >= 0)
+ return Parrot_pmc_new_init_int(INTERP,
+ VTABLE_type(INTERP, SELF), c);
else {
PMC *temp;
maybe_throw_overflow_error(INTERP);
- temp = Parrot_pmc_new(INTERP, enum_class_BigInt);
- VTABLE_set_integer_native(INTERP, temp, a);
+ temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, a);
return VTABLE_subtract(INTERP, temp, value, dest);
}
}
@@ -495,8 +479,8 @@
MULTI PMC *subtract(BigInt value, PMC *dest) {
PMC *temp;
maybe_throw_overflow_error(INTERP);
- temp = Parrot_pmc_new(INTERP, enum_class_BigInt);
- VTABLE_set_integer_native(INTERP, temp, SELF.get_integer());
+ temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt,
+ SELF.get_integer());
return VTABLE_subtract(INTERP, temp, value, dest);
}
@@ -524,17 +508,13 @@
const INTVAL a = SELF.get_integer();
const INTVAL c = a - b;
- if ((c^a) >= 0 || (c^~b) >= 0) {
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
- VTABLE_set_integer_native(INTERP, dest, c);
- return dest;
- }
+ if ((c^a) >= 0 || (c^~b) >= 0)
+ return Parrot_pmc_new_init_int(INTERP,
+ VTABLE_type(INTERP, SELF), c);
else {
PMC *temp;
maybe_throw_overflow_error(INTERP);
- temp = Parrot_pmc_new(INTERP, enum_class_BigInt);
- VTABLE_set_integer_native(INTERP, temp, a);
+ temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, a);
return VTABLE_subtract_int(INTERP, temp, b, dest);
}
}
@@ -624,17 +604,13 @@
const INTVAL c = a * b;
const double cf = (double)a * (double)b;
- if ((double) c == cf) {
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
- VTABLE_set_integer_native(INTERP, dest, c);
- return dest;
- }
+ if ((double) c == cf)
+ return Parrot_pmc_new_init_int(INTERP,
+ VTABLE_type(INTERP, SELF), c);
else {
PMC *temp;
maybe_throw_overflow_error(INTERP);
- temp = Parrot_pmc_new(INTERP, enum_class_BigInt);
- VTABLE_set_integer_native(INTERP, temp, a);
+ temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, a);
return VTABLE_multiply(INTERP, temp, value, dest);
}
}
@@ -657,10 +633,8 @@
MULTI PMC *multiply(DEFAULT value, PMC *dest) {
const FLOATVAL valf = VTABLE_get_number(INTERP, value);
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
- VTABLE_set_number_native(INTERP, dest, SELF.get_number() * valf);
- return dest;
+ return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF),
+ SELF.get_number() * valf);
}
@@ -669,17 +643,13 @@
const INTVAL c = a * b;
const double cf = (double)a * (double)b;
- if ((double) c == cf) {
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
- VTABLE_set_integer_native(INTERP, dest, c);
- return dest;
- }
+ if ((double) c == cf)
+ return Parrot_pmc_new_init_int(INTERP,
+ VTABLE_type(INTERP, SELF), c);
else {
PMC *temp;
maybe_throw_overflow_error(INTERP);
- temp = Parrot_pmc_new(INTERP, enum_class_BigInt);
- VTABLE_set_integer_native(INTERP, temp, a);
+ temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt, a);
return VTABLE_multiply_int(INTERP, temp, b, dest);
}
}
@@ -765,8 +735,8 @@
MULTI PMC *divide(BigInt value, PMC *dest) {
PMC *temp;
maybe_throw_overflow_error(INTERP);
- temp = Parrot_pmc_new(INTERP, enum_class_BigInt);
- VTABLE_set_integer_native(INTERP, temp, SELF.get_integer());
+ temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt,
+ SELF.get_integer());
return VTABLE_divide(INTERP, temp, value, dest);
}
@@ -777,9 +747,8 @@
Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO,
"float division by zero");
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
- VTABLE_set_number_native(INTERP, dest, SELF.get_number() / d);
- return dest;
+ return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF),
+ SELF.get_number() / d);
}
@@ -826,8 +795,8 @@
MULTI PMC *floor_divide(BigInt value, PMC *dest) {
PMC *temp;
maybe_throw_overflow_error(INTERP);
- temp = Parrot_pmc_new(INTERP, enum_class_BigInt);
- VTABLE_set_integer_native(INTERP, temp, SELF.get_integer());
+ temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt,
+ SELF.get_integer());
return VTABLE_floor_divide(INTERP, temp, value, dest);
}
@@ -840,11 +809,9 @@
Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO,
"float division by zero");
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
f = floor(SELF.get_number() / d);
- VTABLE_set_integer_native(INTERP, dest, (INTVAL)f);
- return dest;
+ return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF),
+ (INTVAL)f);
}
@@ -855,12 +822,9 @@
Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO,
"float division by zero");
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
f = floor(SELF.get_number() / value);
- VTABLE_set_integer_native(INTERP, dest, (INTVAL)f);
-
- return dest;
+ return Parrot_pmc_new_init_int(INTERP,
+ VTABLE_type(INTERP, SELF), (INTVAL)f);
}
VTABLE PMC *floor_divide_float(FLOATVAL value, PMC *dest) {
@@ -870,12 +834,9 @@
Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO,
"float division by zero");
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
f = floor(SELF.get_number() / value);
- VTABLE_set_integer_native(INTERP, dest, (INTVAL)f);
-
- return dest;
+ return Parrot_pmc_new_init_int(INTERP,
+ VTABLE_type(INTERP, SELF), (INTVAL)f);
}
MULTI void i_floor_divide(BigInt value) {
@@ -948,8 +909,8 @@
MULTI PMC *modulus(BigInt value, PMC *dest) {
PMC *temp;
maybe_throw_overflow_error(INTERP);
- temp = Parrot_pmc_new(INTERP, enum_class_BigInt);
- VTABLE_set_integer_native(INTERP, temp, SELF.get_integer());
+ temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt,
+ SELF.get_integer());
return VTABLE_modulus(INTERP, temp, value, dest);
}
@@ -961,11 +922,8 @@
Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO,
"int modulus by zero");
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
- VTABLE_set_integer_native(INTERP, dest,
+ return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF),
intval_mod(SELF.get_integer(), d));
- return dest;
}
@@ -974,11 +932,8 @@
Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO,
"int modulus by zero");
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
- VTABLE_set_integer_native(INTERP, dest,
+ return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF),
intval_mod(SELF.get_integer(), value));
- return dest;
}
@@ -987,11 +942,8 @@
Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_DIV_BY_ZERO,
"int modulus by zero");
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
- VTABLE_set_integer_native(INTERP, dest,
+ return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF),
intval_mod(SELF.get_integer(), (INTVAL)value));
- return dest;
}
@@ -1045,15 +997,16 @@
VTABLE INTVAL is_equal(PMC *value) {
INTVAL retval;
- PMC *temp;
switch (value->vtable->base_type) {
case enum_class_BigInt:
- temp = Parrot_pmc_new(INTERP, enum_class_BigInt);
- VTABLE_set_integer_native(INTERP, temp, SELF.get_integer());
+ {
+ PMC const *temp = Parrot_pmc_new_init_int(INTERP, enum_class_BigInt,
+ SELF.get_integer());
Parrot_mmd_multi_dispatch_from_c_args(INTERP,
"is_equal", "PP->I", temp, value, &retval);
return retval;
+ }
break;
default:
return (VTABLE_get_integer(INTERP, SELF)
@@ -1074,15 +1027,20 @@
*/
MULTI INTVAL cmp(String value) {
- const FLOATVAL fdiff = SELF.get_number() - VTABLE_get_number(INTERP, value);
+ INTVAL iv;
+ GET_ATTR_iv(INTERP, SELF, iv);
+ {
+ const FLOATVAL fdiff =
+ (FLOATVAL)iv - VTABLE_get_number(INTERP, value);
- if (FLOAT_IS_ZERO(fdiff)) {
- const INTVAL idiff =
- SELF.get_integer() - VTABLE_get_integer(INTERP, value);
- return idiff > 0 ? 1 : idiff < 0 ? -1 : 0;
- }
+ if (FLOAT_IS_ZERO(fdiff)) {
+ const INTVAL idiff =
+ SELF.get_integer() - VTABLE_get_integer(INTERP, value);
+ return idiff > 0 ? 1 : idiff < 0 ? -1 : 0;
+ }
- return fdiff > 0 ? 1 : -1;
+ return fdiff > 0 ? 1 : -1;
+ }
}
@@ -1210,11 +1168,7 @@
const INTVAL a = abs(SELF.get_integer());
/* TT # 1245 overflow for -maxint */
- dest = Parrot_pmc_new(INTERP, VTABLE_type(INTERP, SELF));
-
- VTABLE_set_integer_native(INTERP, dest, a);
- return dest;
-
+ return Parrot_pmc_new_init_int(INTERP, VTABLE_type(INTERP, SELF), a);
}
Modified: branches/html_cleanup/src/pmc/multisub.pmc
==============================================================================
--- branches/html_cleanup/src/pmc/multisub.pmc Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/pmc/multisub.pmc Wed Sep 1 06:33:06 2010 (r48748)
@@ -34,13 +34,9 @@
}
VTABLE void push_pmc(PMC *value) {
- STRING * const _sub = CONST_STRING(INTERP, "Sub");
- STRING * const _nci = CONST_STRING(INTERP, "NCI");
-
- if (!VTABLE_isa(INTERP, value, _sub)
- && !VTABLE_isa(INTERP, value, _nci))
- Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION,
- "attempt to push non Sub PMC");
+ if (!VTABLE_does(INTERP, value, CONST_STRING(INTERP, "invokable")))
+ Parrot_ex_throw_from_c_args(INTERP, NULL,
+ EXCEPTION_INVALID_OPERATION, "attempt to push non Sub PMC");
SUPER(value);
}
Modified: branches/html_cleanup/src/pmc/namespace.pmc
==============================================================================
--- branches/html_cleanup/src/pmc/namespace.pmc Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/pmc/namespace.pmc Wed Sep 1 06:33:06 2010 (r48748)
@@ -427,7 +427,7 @@
:value->vtable->base_type == enum_class_NameSpace;
/* don't need this everywhere yet */
- PMC * const old = (PMC *)parrot_hash_get(INTERP, (Hash *)SELF.get_pointer(), key);
+ PMC *old;
/* If it's a sub... */
if (maybe_add_sub_to_namespace(INTERP, SELF, key, value))
@@ -439,6 +439,8 @@
/* If it's a multi-sub and the first in this NS... */
add_multi_to_namespace(INTERP, SELF, key, value);
+ old = (PMC *)parrot_hash_get(INTERP, (Hash *)SELF.get_pointer(), key);
+
if (!old)
SUPER(key, value);
else {
Modified: branches/html_cleanup/src/pmc/parrotlibrary.pmc
==============================================================================
--- branches/html_cleanup/src/pmc/parrotlibrary.pmc Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/pmc/parrotlibrary.pmc Wed Sep 1 06:33:06 2010 (r48748)
@@ -1,5 +1,5 @@
/*
-Copyright (C) 2001-2009, Parrot Foundation.
+Copyright (C) 2001-2010, Parrot Foundation.
$Id$
=head1 NAME
@@ -49,9 +49,7 @@
*/
- VTABLE void init() {
- PObj_custom_destroy_SET(SELF);
- }
+ VTABLE void init() {}
/*
@@ -82,8 +80,14 @@
VTABLE PMC *clone() {
PMC * const dest = Parrot_pmc_new(INTERP, SELF->vtable->base_type);
- PMC_oplib_init(dest) = PMC_oplib_init(SELF);
- PMC_dlhandle(dest) = PMC_dlhandle(SELF);
+
+ if (PMC_oplib_init(SELF))
+ PMC_oplib_init(dest) = PMC_oplib_init(SELF);
+
+ if (PMC_dlhandle(SELF)) {
+ PMC_dlhandle(dest) = PMC_dlhandle(SELF);
+ PObj_custom_destroy_SET(dest);
+ }
if (PMC_metadata(SELF))
PMC_metadata(dest) = VTABLE_clone(INTERP, PMC_metadata(SELF));
@@ -126,7 +130,7 @@
=item C<void *get_pointer()>
-Get the pointer to the shared library handle.
+Gets the pointer to the shared library handle.
=cut
@@ -140,7 +144,7 @@
=item C<void set_pointer(void *handle)>
-Set the pointer to the shared library handle.
+Sets the pointer to the shared library handle.
=cut
@@ -148,6 +152,7 @@
VTABLE void set_pointer(void *handle) {
PMC_dlhandle(SELF) = handle;
+ PObj_custom_destroy_SET(SELF);
}
}
@@ -155,16 +160,6 @@
=back
-=head1 SEE ALSO
-
- Date: Mon, 29 Sep 2003 14:37:11 -0400 (EDT)
- Subject: Library loading and initialization sequence
- From: Dan Sugalski
-
-=head1 HISTORY
-
-Initial version by leo 2003.10.12.
-
=cut
*/
Modified: branches/html_cleanup/src/runcore/main.c
==============================================================================
--- branches/html_cleanup/src/runcore/main.c Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/runcore/main.c Wed Sep 1 06:33:06 2010 (r48748)
@@ -322,6 +322,11 @@
interp->cores = NULL;
interp->run_core = NULL;
+ if (interp->all_op_libs)
+ mem_gc_free(interp, interp->all_op_libs);
+
+ interp->all_op_libs = NULL;
+
/* dynop libs */
if (interp->n_libs <= 0)
return;
Modified: branches/html_cleanup/src/scheduler.c
==============================================================================
--- branches/html_cleanup/src/scheduler.c Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/scheduler.c Wed Sep 1 06:33:06 2010 (r48748)
@@ -111,8 +111,7 @@
=item C<void Parrot_cx_handle_tasks(PARROT_INTERP, PMC *scheduler)>
Handle the pending tasks in the scheduler's task list. Returns when there are
-no more pending tasks. Returns 0 to terminate the scheduler runloop, or 1 to
-continue the runloop.
+no more pending tasks.
=cut
@@ -123,6 +122,12 @@
Parrot_cx_handle_tasks(PARROT_INTERP, ARGMOD(PMC *scheduler))
{
ASSERT_ARGS(Parrot_cx_handle_tasks)
+
+ /* avoid recursive calls */
+ if (SCHEDULER_in_handler_TEST(scheduler))
+ return;
+
+ SCHEDULER_in_handler_SET(scheduler);
SCHEDULER_wake_requested_CLEAR(scheduler);
Parrot_cx_refresh_task_list(interp, scheduler);
@@ -159,6 +164,8 @@
Parrot_cx_refresh_task_list(interp, scheduler);
} /* end of pending tasks */
+
+ SCHEDULER_in_handler_CLEAR(scheduler);
}
/*
Modified: branches/html_cleanup/src/string/api.c
==============================================================================
--- branches/html_cleanup/src/string/api.c Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/src/string/api.c Wed Sep 1 06:33:06 2010 (r48748)
@@ -3300,7 +3300,7 @@
if (s->encoding != e || s->charset != c) {
STRING *new_s = e->to_encoding(interp, s);
chunks[i] = new_s;
- total_length += s->bufused - new_s->bufused;
+ total_length += new_s->bufused - s->bufused;
}
}
}
Modified: branches/html_cleanup/t/codingstd/c_operator.t
==============================================================================
--- branches/html_cleanup/t/codingstd/c_operator.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/codingstd/c_operator.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -75,11 +75,11 @@
$buf = strip_pod($buf);
}
- # strip ', ", and C comments
+ # strip ', ", and C comments #'
$buf =~ s{ (?:
- (?: (') (?: \\\\ | \\' | [^'] )* (') ) # remove ' string
- | (?: (") (?: \\\\ | \\" | [^"] )* (") ) # remove " string
- | /(\*) .*? (\*)/ # remove C comment
+ (?: (') (?: \\\\ | \\' | [^'] )* (') ) # rm ' string #'
+ | (?: (") (?: \\\\ | \\" | [^"] )* (") ) # rm " string #"
+ | /(\*) .*? (\*)/ # rm C comment
)
}{defined $1 ? "$1$2" : defined $3 ? "$3$4" : "$5$6"}egsx;
@@ -88,23 +88,24 @@
for (my $i=0; $i <= $#lines; $i++) {
# after a comma there should be one space or a newline
if ( $lines[$i] =~ m{ ( (?:,) (?! \s ) (?= .+) ) }gx ) {
- push @{ $comma_space{$path} }, $i;
+ push @{ $comma_space{$path} }, $lines[$i];
}
}
}
## L<PDD07/Code Formatting"there should be one space or a newline after a comma">/
- my $files_with_errors = 0;
+ my @comma_space_files;
for my $path ( sort keys %comma_space ) {
- $files_with_errors++ if scalar @{ $comma_space{$path} };
+ if (my $cnt = scalar @{ $comma_space{$path} }) {
+ push @comma_space_files, <<"END_ERROR";
+$path [$cnt line@{[ ($cnt >1) ? 's': '' ]}] at :
+@{[ join("\n--\n", @{$comma_space{$path}}) ]}
+END_ERROR
+ }
}
- is( $files_with_errors, 0, "there should be one space or a newline after a comma" )
- or diag( do {
- for my $k (sort keys %comma_space) {
- my @lines_failed = @{$comma_space{$k}};
- print "$k: line(s): @lines_failed\n" if scalar(@lines_failed);
- }
- } );
+ is(join("\n", at comma_space_files),
+ "",
+ "there should be one space or a newline after a comma");
}
# Local Variables:
Modified: branches/html_cleanup/t/codingstd/c_todo.t
==============================================================================
--- branches/html_cleanup/t/codingstd/c_todo.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/codingstd/c_todo.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -60,7 +60,7 @@
my $num_failed_files = scalar keys %failed_files;
TODO: {
- local $TODO = 'some todos remain';
+ local $TODO = scalar(@fixme) . ' todos remain';
ok( !scalar(@fixme), 'FIXME strings' )
or diag( "FIXME strings found in "
Modified: branches/html_cleanup/t/codingstd/perlcritic.t
==============================================================================
--- branches/html_cleanup/t/codingstd/perlcritic.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/codingstd/perlcritic.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -22,7 +22,7 @@
violations.
This test uses a standard perlcriticrc file, located in
-F<tools/utils/perlcritic.conf>
+F<tools/dev/perlcritic.conf>
If you wish to run a specific policy, the easiest way to do so is to
temporarily add a custom theme to the configuration file and then specify
@@ -62,7 +62,7 @@
'theme=s' => \$theme
);
-my $config = File::Spec->catfile( $PConfig{build_dir}, qw{tools util perlcritic.conf} );
+my $config = File::Spec->catfile( $PConfig{build_dir}, qw{tools dev perlcritic.conf} );
Test::Perl::Critic->import(
-profile => $config,
Modified: branches/html_cleanup/t/dynoplibs/debug.t
==============================================================================
--- branches/html_cleanup/t/dynoplibs/debug.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/dynoplibs/debug.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -106,7 +106,7 @@
called from Sub 'parrot;Test1;main' pc (\d+|-1) \(.*?:(\d+|-1)\)$/
OUTPUT
-pir_error_output_like( <<'CODE', <<'OUTPUT', "debug backtrace - fetch of unknown lexical" );
+pir_error_output_like( <<'CODE', <<'OUTPUT', "debug backtrace - division by 0" );
.namespace ["Test2"]
.sub main
print "ok 1\n"
@@ -115,13 +115,14 @@
.end
.sub foo :lex
print "ok 2\n"
- find_lex $P0, "nosuchlex"
+ $I1 = 0
+ div $I2, $I2, 0
print "not ok 3\n"
.end
CODE
/^ok 1
ok 2
-Lexical 'nosuchlex' not found
+Divide by zero
current instr.: 'parrot;Test2;foo' pc (\d+|-1) \(.*?:(\d+|-1)\)
called from Sub 'parrot;Test2;main' pc (\d+|-1) \(.*?:(\d+|-1)\)$/
OUTPUT
Copied: branches/html_cleanup/t/examples/pgegrep.t (from r48747, trunk/t/examples/pgegrep.t)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/t/examples/pgegrep.t Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/t/examples/pgegrep.t)
@@ -0,0 +1,111 @@
+#! perl
+# Copyright (C) 2009, Parrot Foundation.
+# $Id$
+
+=head1 NAME
+
+t/tools/pgegrep.t - test the script tools/utils/pgegrep
+
+=head1 SYNOPSIS
+
+ % prove t/examples/tools/pgegrep.t
+
+=head1 DESCRIPTION
+
+Tests the features of of the C<pgegrep> utility (see F<examples/pgegrep>).
+
+=cut
+
+use strict;
+use warnings;
+use lib qw( . lib ../lib ../../lib );
+
+use Fatal qw{open close};
+use Test::More;
+use Parrot::Test tests => 10;
+use Parrot::Config;
+use File::Spec ();
+
+my $testdata = File::Spec->catfile(qw{. t tools testdata });
+my $testdata_escaped = $testdata;
+$testdata_escaped =~ s!\\!\\\\!g;
+
+sub pgegrep_output_like {
+ my ($options, $snippet, $desc) = @_;
+
+ my $PARROT = ".$PConfig{slash}$PConfig{test_prog}";
+ my $pgegrep = File::Spec->catfile( qw{. examples tools pgegrep} );
+ my $out = `$PARROT $pgegrep $options`;
+
+ like( $out, $snippet, $desc );
+
+ return;
+}
+
+pgegrep_output_like(
+ '-V',
+ qr!\Qpgegrep v0.0.1\E!,
+ 'pge reports correct version'
+);
+
+pgegrep_output_like(
+ "cat $testdata",
+ qr!keyboardcat!,
+ 'basic sanity of matching a literal'
+);
+
+pgegrep_output_like(
+ "-n cat $testdata",
+ qr!1:keyboardcat!,
+ 'matching a literal with line number'
+);
+
+pgegrep_output_like(
+ "--line-number cat $testdata",
+ qr!1:keyboardcat!,
+ 'matching a literal with line number with long option'
+);
+
+pgegrep_output_like(
+ "-H cat $testdata",
+ qr!$testdata_escaped:keyboardcat!,
+ 'matching a literal with file name'
+);
+
+pgegrep_output_like(
+ "--with-filename cat $testdata",
+ qr!$testdata_escaped:keyboardcat!,
+ 'matching a literal with file name with long option'
+);
+
+
+pgegrep_output_like(
+ "-v cat $testdata",
+ qr!saxophonegiraffe!,
+ 'test inversion of match'
+);
+
+pgegrep_output_like(
+ "--invert-match cat $testdata",
+ qr!saxophonegiraffe!,
+ 'test inversion of match with long option'
+);
+
+pgegrep_output_like(
+ "-l cat $testdata",
+ qr!$testdata_escaped!,
+ 'find files that match'
+);
+
+pgegrep_output_like(
+ "--files-with-matches cat $testdata",
+ qr!$testdata_escaped!,
+ 'find files that match with long option'
+);
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Modified: branches/html_cleanup/t/oo/isa.t
==============================================================================
--- branches/html_cleanup/t/oo/isa.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/oo/isa.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -20,7 +20,7 @@
.sub main :main
.include 'test_more.pir'
- plan(29)
+ plan(30)
isa_by_string_name()
isa_by_class_object()
@@ -28,6 +28,7 @@
subclass_isa_by_class_object()
string_isa_and_pmc_isa_have_same_result()
string_register_and_string_pmc_isa_have_same_result()
+ isa_accepts_rsa()
.end
@@ -181,6 +182,14 @@
ok( $I0, '... and false when it is not' )
.end
+.sub isa_accepts_rsa
+ $P0 = newclass ['Foo';'Buz']
+ $P1 = new $P0
+ $P0 = split "::", "Foo::Buz"
+ $I0 = isa $P1, $P0
+ ok($I0, "isa accepts a ResizablePMCArray")
+ .end
+
.HLL 'foo'
.namespace ['XYZ']
Modified: branches/html_cleanup/t/op/gc-leaky-box.t
==============================================================================
--- branches/html_cleanup/t/op/gc-leaky-box.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/op/gc-leaky-box.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -47,7 +47,7 @@
loop:
$P0 = box 0
inc counter
- if counter < 10e6 goto loop
+ if counter < 2e6 goto loop
$I1 = interpinfo.INTERPINFO_GC_COLLECT_RUNS
$I2 = interpinfo.INTERPINFO_GC_MARK_RUNS
Modified: branches/html_cleanup/t/op/gc-leaky-call.t
==============================================================================
--- branches/html_cleanup/t/op/gc-leaky-call.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/op/gc-leaky-call.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -44,7 +44,7 @@
loop:
consume()
inc counter
- if counter < 10e6 goto loop
+ if counter < 1e6 goto loop
$I1 = interpinfo.INTERPINFO_GC_COLLECT_RUNS
$I2 = interpinfo.INTERPINFO_GC_MARK_RUNS
Modified: branches/html_cleanup/t/op/lexicals.t
==============================================================================
--- branches/html_cleanup/t/op/lexicals.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/op/lexicals.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -840,7 +840,7 @@
/Null PMC access/
OUT
-pir_error_output_like( <<'CODE', <<'OUTPUT', 'get non existing' );
+pir_output_is( <<'CODE', <<'OUTPUT', 'get undefined lexical' );
.sub "main" :main
.lex 'a', $P0
foo()
@@ -852,9 +852,14 @@
.sub bar :outer('foo')
.lex 'c', $P0
$P2 = find_lex 'no_such'
+ if null $P2 goto ok
+ print "Undefined name not NULL\n"
+ end
+ok:
+ print "ok\n"
.end
CODE
-/Lexical 'no_such' not found/
+ok
OUTPUT
pir_output_is( <<'CODE', <<'OUTPUT', 'find_name on lexicals' );
Modified: branches/html_cleanup/t/pmc/exception.t
==============================================================================
--- branches/html_cleanup/t/pmc/exception.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/pmc/exception.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -20,10 +20,11 @@
.sub main :main
.include 'test_more.pir'
- plan(27)
+ plan(37)
test_bool()
test_int()
- test_get_integer_keyed()
+ test_integer_keyed()
+ test_string_keyed()
test_attrs()
test_attributes()
test_push_pop_eh()
@@ -31,7 +32,9 @@
test_push_eh_throw()
test_die()
test_throw_obj()
+ test_clone()
test_throw_clone()
+ test_backtrace()
.end
.sub test_bool
@@ -46,30 +49,100 @@
is($I0, 42, 'set/get integer on Exception')
.end
-.sub test_get_integer_keyed
+.sub test_integer_keyed
.local pmc ex, eh
.local int value
ex = new ['Exception']
+
value = ex['type']
is(value, 0, 'get type default value')
+ ex['type'] = .EXCEPTION_SYNTAX_ERROR
+ value = ex['type']
+ is(value, .EXCEPTION_SYNTAX_ERROR, 'get type value changed')
+
value = ex['exit_code']
is(value, 0, 'get exit_code default value')
+ ex['exit_code'] = 127
+ value = ex['exit_code']
+ is(value, 127, 'get exit_code value changed')
+
value = ex['handled']
is(value, 0, 'get handled default is false')
+ ex['handled'] = 1
+ value = ex['handled']
+ is(value, 1, 'get handled value changed')
eh = new ['ExceptionHandler']
eh.'handle_types'(.EXCEPTION_ATTRIB_NOT_FOUND)
set_label eh, catch
push_eh eh
value = 1
- value = ex['the droids you are looking for']
+ ex['the droids you are looking for'] = 42
value = 0
catch:
finalize eh
- pop_eh
- is(value, 1, 'invalid key throws')
+ is(value, 1, 'set invalid key throws')
+
+ set_label eh, catch2
+ value = 1
+ value = ex['the droids you are looking for']
+ value = 0
+ catch2:
+ finalize eh
+ is(value, 1, 'get invalid key throws')
+.end
+
+.sub test_string_keyed
+ .local pmc ex, eh
+ .local string value
+ .const string TEST_VALUE = 'fubar'
+ ex = new ['Exception']
+ ex['message'] = TEST_VALUE
+ value = ex['message']
+ is(value, TEST_VALUE, 'set/get string_keyed')
+.end
+
+
+.sub setattr_int
+ .param pmc obj
+ .param string attrname
+ .param int value
+ $P0 = new ['Integer'], value
+ setattribute obj, attrname, $P0
+.end
+
+.sub setattr_string
+ .param pmc obj
+ .param string attrname
+ .param string value
+ $P0 = new ['String']
+ $P0 = value
+ setattribute obj, attrname, $P0
.end
+.sub gotattr_int
+ .param pmc obj
+ .param string attrname
+ .param int checkvalue
+
+ $S0 = 'got ' . attrname
+ $P1 = getattribute obj, attrname
+ $I1 = $P1
+ is($I1, checkvalue, $S0)
+.end
+
+.sub gotattr_string
+ .param pmc obj
+ .param string attrname
+ .param string checkvalue
+
+ $S0 = 'got ' . attrname
+ $P1 = getattribute obj, attrname
+ $S1 = $P1
+ is($S1, checkvalue, $S0)
+.end
+
+
.sub test_attrs
$P0 = new 'ExceptionHandler'
set_addr $P0, _handler
@@ -86,53 +159,56 @@
getattribute $P4, $P0, 'severity'
ok(1,'got severity')
- push_eh done
+ push_eh catch
$I0 = 1
getattribute $P5, $P0, 'foo'
$I0 = 0
+ goto done
+ catch:
+ .get_results($P0)
+ finalize $P0
done:
ok($I0, "Can't fetch non-existent attribute")
.end
.sub test_attributes
- push_eh handler
$P1 = new ['Exception']
- $P2 = new ['String']
- $P2 = "just pining"
- setattribute $P1, 'message', $P2
- $P3 = new ['Integer']
- $P3 = 5
- setattribute $P1, 'severity', $P3
- $P4 = new ['String']
- $P4 = "additional payload"
- setattribute $P1, 'payload', $P4
- $P5 = new ['ResizablePMCArray']
- $P5 = 2
- $P5[0] = 'backtrace line 1'
- $P5[1] = 'backtrace line 2'
- setattribute $P1, 'backtrace', $P5
+ setattr_int($P1, 'type', 5)
+ setattr_int($P1, 'severity', 6)
+ setattr_int($P1, 'exit_code', 7)
+ setattr_int($P1, 'handled', 1)
+ setattr_string($P1, 'message', "just pining")
+ setattr_string($P1, 'payload', "additional payload")
+
+ $P8 = new ['ResizablePMCArray']
+ $P8 = 2
+ $P8[0] = 'backtrace line 1'
+ $P8[1] = 'backtrace line 2'
+ setattribute $P1, 'backtrace', $P8
+
+ push_eh handler
throw $P1
- is(0, "throwing exception failed")
+ ok(0, "throwing exception failed")
+ skip(7, "because of throwing exception failed")
.return()
handler:
.get_results($P0)
+ pop_eh
- $P16 = getattribute $P0, 'message'
- is($P16, "just pining", 'got message')
-
- $P17 = getattribute $P0, 'severity'
- is($P17, 5, 'got severity')
-
- $P18 = getattribute $P0, 'payload'
- is($P18, "additional payload", 'got payload')
-
- $P19 = getattribute $P0, 'backtrace'
- $P20 = $P19[0]
- is($P20, "backtrace line 1", 'got backtrace data')
+ gotattr_int($P0, 'type', 5)
+ gotattr_int($P0, 'severity', 6)
+ gotattr_int($P0, 'exit_code', 7)
+ gotattr_int($P0, 'handled', 1)
+ gotattr_string($P0, 'message', "just pining")
+ gotattr_string($P0, 'payload', "additional payload")
+
+ $P28 = getattribute $P0, 'backtrace'
+ $P30 = $P28[0]
+ is($P30, "backtrace line 1", 'got backtrace data')
- $P20 = $P19[1]
- is($P20, "backtrace line 2", 'more backtrace data')
+ $P31 = $P28[1]
+ is($P31, "backtrace line 2", 'more backtrace data')
.end
.sub test_push_pop_eh
@@ -192,6 +268,20 @@
.end
# Test clone vtable function
+
+.sub test_clone
+ .local pmc ex, exclone
+ ex = new ['Exception']
+ ex['type'] = .EXCEPTION_SYNTAX_ERROR
+ exclone = clone ex
+ .local int result
+ result = iseq ex, exclone
+ is(result, 1, 'cloned Exception is equal to original')
+ exclone['type'] = .EXCEPTION_ERR_OVERFLOW
+ result = iseq ex, exclone
+ is(result, 0, 'cloned and modified Exception is not equal to original')
+.end
+
.sub test_throw_clone
.local pmc ex, exclone, eh, ehguard
.local int result
@@ -199,9 +289,6 @@
ex['type'] = .EXCEPTION_SYNTAX_ERROR
exclone = clone ex
- result = iseq ex, exclone
- is(result, 1, 'cloned Exception is equal to original')
-
ehguard = new ['ExceptionHandler']
set_label ehguard, catchall
push_eh ehguard
@@ -244,6 +331,14 @@
is(result, 1, 'caught a cloned Exception with payload')
.end
+.sub test_backtrace
+ .local pmc ex, bt
+ ex = new ['Exception']
+ bt = ex.'backtrace'()
+ $I0 = isnull bt
+ is($I0, 0, 'got backtrace from unthrow Exception')
+.end
+
# Local Variables:
# mode: pir
# fill-column: 100
Modified: branches/html_cleanup/t/pmc/hash.t
==============================================================================
--- branches/html_cleanup/t/pmc/hash.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/pmc/hash.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -25,11 +25,12 @@
.sub main :main
.include 'test_more.pir'
- plan(172)
+ plan(174)
initial_hash_tests()
more_than_one_hash()
hash_key_type()
+ hash_value_type()
null_key()
hash_keys_with_nulls_in_them()
nearly_the_same_hash_keys()
@@ -156,6 +157,26 @@
end:
.end
+.sub hash_value_type
+ .local pmc h, eh
+ .local int r
+ h = new ['Hash']
+
+ h.'set_value_type'(.DATATYPE_INTVAL)
+ r = h.'get_value_type'()
+ is(r, .DATATYPE_INTVAL, 'get/set _value_type')
+
+ r = 1
+ eh = new ['ExceptionHandler']
+ eh.'handle_types'(.EXCEPTION_UNIMPLEMENTED)
+ set_label eh, catch
+ push_eh eh
+ h.'set_value_type'(999999)
+ r = 0
+ catch:
+ is(r, 1, 'set_value_type with invalid type throws')
+.end
+
.sub null_key
new $P0, ['Hash']
$P0['yum'] = 5
Modified: branches/html_cleanup/t/pmc/stringiterator.t
==============================================================================
--- branches/html_cleanup/t/pmc/stringiterator.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/pmc/stringiterator.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -17,11 +17,12 @@
=cut
.include 'iterator.pasm'
+.include 'except_types.pasm'
.sub main :main
.include 'test_more.pir'
- plan(24)
+ plan(28)
test_clone()
test_elements()
@@ -29,6 +30,7 @@
iterate_backward() # 8 tests
iterate_wrong() # 1 test
iterate_out() # 1 test
+ get_keyed()
.end
@@ -208,6 +210,44 @@
end:
.end
+.sub get_keyed
+ .local pmc s, it, eh
+ .local string s1
+ .local int result, i1
+ result = 0
+ s = new ['String']
+ s = 'hi'
+ it = iter s
+ s1 = it[0]
+ is(s1, 'h', 'get_string_keyed_int')
+
+ eh = new ['ExceptionHandler']
+ eh.'handle_types'(.EXCEPTION_OUT_OF_BOUNDS)
+ set_label eh, catch
+ push_eh eh
+ s1 = it[2]
+ goto done
+ catch:
+ finalize eh
+ result = 1
+ done:
+ ok(result, 'get_string_keyed_int out of bounds')
+
+ result = 0
+ i1 = it[0]
+ s1 = chr i1
+ is(s1, 'h', 'get_integer_keyed_int')
+
+ set_label eh, catch2
+ i1 = it[2]
+ goto done2
+ catch2:
+ finalize eh
+ result = 1
+ done2:
+ ok(result, 'get_integer_keyed_int out of bounds')
+.end
+
# Local Variables:
# mode: pir
# fill-column: 100
Modified: branches/html_cleanup/t/pmc/timer.t
==============================================================================
--- branches/html_cleanup/t/pmc/timer.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/pmc/timer.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -6,7 +6,7 @@
use warnings;
use lib qw( . lib ../lib ../../lib );
use Test::More;
-use Parrot::Test tests => 6;
+use Parrot::Test tests => 7;
use Parrot::Config;
=head1 NAME
@@ -200,6 +200,38 @@
0
OUTPUT
+pir_output_is( << 'CODE', << 'OUTPUT', "Timer - many repetitions" );
+
+.include 'timer.pasm'
+
+.sub expired
+ $P0 = get_global "expired_count"
+ inc $P0
+.end
+
+.sub main :main
+ $P2 = new 'Integer'
+ set_global "expired_count", $P2
+
+ $P0 = new 'Timer'
+ $P1 = get_global "expired"
+
+ $P0[.PARROT_TIMER_HANDLER] = $P1
+ $P0[.PARROT_TIMER_SEC] = 0
+ $P0[.PARROT_TIMER_REPEAT] = 9999
+ $P0[.PARROT_TIMER_RUNNING] = 1
+
+loop:
+ sleep 0
+ if $P2 < 10000 goto loop
+
+ sleep 0.5
+ say $P2
+.end
+CODE
+10000
+OUTPUT
+
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
Modified: branches/html_cleanup/t/run/options.t
==============================================================================
--- branches/html_cleanup/t/run/options.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/run/options.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -20,7 +20,7 @@
use warnings;
use lib qw( lib . ../lib ../../lib );
-use Test::More tests => 27;
+use Test::More tests => 28;
use Parrot::Config;
use File::Temp 0.13 qw/tempfile/;
use File::Spec;
@@ -119,6 +119,14 @@
return $filename;
}
+#make sure that VERSION matches the output of --version
+open(my $version_fh, "<", "VERSION") or die "couldn't open VERSION: $!";
+my $file_version = <$version_fh>;
+chomp($file_version);
+close($version_fh);
+like( qx{$PARROT --version}, qr/.*${file_version}.*/, "VERSION matches --version" );
+
+
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
Modified: branches/html_cleanup/t/src/extend.t
==============================================================================
--- branches/html_cleanup/t/src/extend.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/src/extend.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -43,15 +43,13 @@
Parrot_Int new_value;
/* Interpreter set-up */
- if (!interp)
- return 1;
-
- Parrot_set_intreg(interp, parrot_reg, value);
- new_value = Parrot_get_intreg(interp, parrot_reg);
-
- printf("%d\n", (int)new_value);
+ if (interp) {
+ Parrot_set_intreg(interp, parrot_reg, value);
+ new_value = Parrot_get_intreg(interp, parrot_reg);
- Parrot_exit(interp, 0);
+ printf("%d\n", (int)new_value);
+ Parrot_destroy(interp);
+ }
return 0;
}
@@ -74,15 +72,14 @@
Parrot_Float new_value;
/* Interpreter set-up */
- if (!interp)
- return 1;
-
- Parrot_set_numreg(interp, parrot_reg, value);
- new_value = Parrot_get_numreg(interp, parrot_reg);
+ if (interp) {
+ Parrot_set_numreg(interp, parrot_reg, value);
+ new_value = Parrot_get_numreg(interp, parrot_reg);
- printf("%.1f\n", (double)new_value);
+ printf("%.1f\n", (double)new_value);
- Parrot_exit(interp, 0);
+ Parrot_destroy(interp);
+ }
return 0;
}
@@ -103,13 +100,12 @@
Parrot_String output;
/* Interpreter set-up */
- if (!interp)
- return 1;
-
- output = Parrot_new_string(interp, "Test", 4, "iso-8859-1", 0);
- Parrot_eprintf(interp, "%S\n", output);
+ if (interp) {
+ output = Parrot_new_string(interp, "Test", 4, "iso-8859-1", 0);
+ Parrot_eprintf(interp, "%S\n", output);
- Parrot_exit(interp, 0);
+ Parrot_destroy(interp);
+ }
return 0;
}
@@ -131,16 +127,15 @@
Parrot_String value, new_value;
/* Interpreter set-up */
- if (!interp)
- return 1;
+ if (interp) {
+ value = Parrot_new_string(interp, "Test", 4, "iso-8859-1", 0);
+ Parrot_set_strreg(interp, parrot_reg, value);
- value = Parrot_new_string(interp, "Test", 4, "iso-8859-1", 0);
- Parrot_set_strreg(interp, parrot_reg, value);
+ new_value = Parrot_get_strreg(interp, parrot_reg);
+ Parrot_eprintf(interp, "%S\n", new_value);
- new_value = Parrot_get_strreg(interp, parrot_reg);
- Parrot_eprintf(interp, "%S\n", new_value);
-
- Parrot_exit(interp, 0);
+ Parrot_destroy(interp);
+ }
return 0;
}
@@ -163,18 +158,17 @@
Parrot_Int type, new_value;
/* Interpreter set-up */
- if (!interp)
- return 1;
-
- type = Parrot_PMC_typenum(interp, "Integer");
- testpmc = Parrot_PMC_new(interp, type);
+ if (interp) {
+ type = Parrot_PMC_typenum(interp, "Integer");
+ testpmc = Parrot_PMC_new(interp, type);
- Parrot_PMC_set_integer_native(interp, testpmc, value);
- new_value = Parrot_PMC_get_integer(interp, testpmc);
+ Parrot_PMC_set_integer_native(interp, testpmc, value);
+ new_value = Parrot_PMC_get_integer(interp, testpmc);
- printf("%ld\n", (long)new_value);
+ printf("%ld\n", (long)new_value);
- Parrot_exit(interp, 0);
+ Parrot_destroy(interp);
+ }
return 0;
}
CODE
@@ -211,11 +205,11 @@
Parrot_Interp interp = Parrot_new(NULL);
/* Interpreter set-up */
- if (!interp)
- return 1;
+ if (interp) {
+ Parrot_run_native(interp, the_test);
- Parrot_run_native(interp, the_test);
- Parrot_exit(interp, 0);
+ Parrot_destroy(interp);
+ }
return 0;
}
CODE
@@ -541,7 +535,8 @@
.pcc_sub _sub1:
get_params ""
print "in sub1\n"
- find_lex P2, "no_such_var"
+ set I1, 0 # Divide by 0 to force exception.
+ div I2, I1, 0
print "never\n"
returncc
EOF
Copied: branches/html_cleanup/t/steps/auto/llvm-01.t (from r48747, trunk/t/steps/auto/llvm-01.t)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/t/steps/auto/llvm-01.t Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/t/steps/auto/llvm-01.t)
@@ -0,0 +1,418 @@
+#!perl
+# Copyright (C) 2001-2007, Parrot Foundation.
+# $Id$
+# auto/llvm-01.t
+
+use strict;
+use warnings;
+use File::Temp qw( tempdir );
+use Test::More tests => 69;
+use Carp;
+use lib qw( lib t/configure/testlib );
+use_ok('config::init::defaults');
+use_ok('config::inter::progs');
+use_ok('config::auto::llvm');
+use Parrot::Configure;
+use Parrot::Configure::Options qw( process_options );
+use Parrot::Configure::Test qw(
+ test_step_thru_runstep
+ rerun_defaults_for_testing
+ test_step_constructor_and_description
+);
+use IO::CaptureOutput qw( capture );
+
+########## regular ##########
+
+my ($args, $step_list_ref) = process_options( {
+ argv => [ ],
+ mode => q{configure},
+} );
+
+my $conf = Parrot::Configure->new;
+
+my $serialized = $conf->pcfreeze();
+
+test_step_thru_runstep($conf, q{init::defaults}, $args);
+test_step_thru_runstep($conf, q{inter::progs}, $args);
+
+my $pkg = q{auto::llvm};
+
+$conf->add_steps($pkg);
+$conf->options->set( %{$args} );
+my $step = test_step_constructor_and_description($conf);
+my $ret = $step->runstep($conf);
+ok( $ret, "runstep() returned true value" );
+like( $step->result(), qr/yes|no/,
+ "Result was either 'yes' or 'no'" );
+
+$conf->replenish($serialized);
+
+########## --verbose ##########
+
+($args, $step_list_ref) = process_options( {
+ argv => [ q{--verbose} ],
+ mode => q{configure},
+} );
+rerun_defaults_for_testing($conf, $args );
+$conf->add_steps($pkg);
+$conf->options->set( %{$args} );
+$step = test_step_constructor_and_description($conf);
+{
+ my $stdout;
+ my $ret = capture(
+ sub { $step->runstep($conf) },
+ \$stdout
+ );
+ ok( $ret, "runstep() returned true value" );
+ like( $step->result(), qr/yes|no/,
+ "Result was either 'yes' or 'no'" );
+ SKIP: {
+ skip 'No sense testing for verbose output if LLVM not present',
+ 2 unless ( $step->result() =~ /yes/ );
+ like( $stdout, qr/llvm-gcc/s,
+ "Got expected verbose output" );
+ like( $stdout, qr/Low Level Virtual Machine/s,
+ "Got expected verbose output" );
+ }
+}
+
+$step->set_result( undef );
+$conf->data->set( 'has_llvm' => undef );
+auto::llvm::_handle_result($step, $conf, 1);
+is( $step->result(), 'yes', "Got expected 'yes' result" );
+ok( $conf->data->get( 'has_llvm' ),
+ "'has_llvm' set to true value, as expected" );
+
+$step->set_result( undef );
+$conf->data->set( 'has_llvm' => undef );
+auto::llvm::_handle_result($step, $conf, 0);
+is( $step->result(), 'no', "Got expected 'no' result" );
+ok( ! $conf->data->get( 'has_llvm' ),
+ "'has_llvm' set to false value, as expected" );
+
+##### _handle_component_version_output() #####
+
+my ($prog, $output, $llvm_lacking, $verbose);
+$prog = [ 'llvm-gcc' => 'llvm-gcc' ];
+
+$verbose = 0;
+
+$output = 'llvm-gcc';
+$llvm_lacking = 0;
+$llvm_lacking = auto::llvm::_handle_component_version_output(
+ $prog, $output, $llvm_lacking, $verbose
+);
+ok( ! $llvm_lacking, "llvm reported as not lacking" );
+
+$output = 'foobar';
+$llvm_lacking = 0;
+$llvm_lacking = auto::llvm::_handle_component_version_output(
+ $prog, $output, $llvm_lacking, $verbose
+);
+ok( $llvm_lacking, "llvm reported as lacking: wrong output" );
+
+$output = undef;
+$llvm_lacking = 0;
+$llvm_lacking = auto::llvm::_handle_component_version_output(
+ $prog, $output, $llvm_lacking, $verbose
+);
+ok( $llvm_lacking, "llvm reported as lacking: output undefined" );
+
+$verbose = 1;
+
+my ($stdout, $stderr);
+my $exp = $prog->[0];
+
+$output = 'llvm-gcc';
+$llvm_lacking = 0;
+capture(
+ sub {
+ $llvm_lacking = auto::llvm::_handle_component_version_output(
+ $prog, $output, $llvm_lacking, $verbose
+ );
+ },
+ \$stdout,
+ \$stderr,
+);
+ok( ! $llvm_lacking, "llvm reported as not lacking" );
+like( $stdout, qr/$output/, "Got expected verbose output: llvm not lacking" );
+
+$output = 'foobar';
+$llvm_lacking = 0;
+capture(
+ sub {
+ $llvm_lacking = auto::llvm::_handle_component_version_output(
+ $prog, $output, $llvm_lacking, $verbose
+ );
+ },
+ \$stdout,
+ \$stderr,
+);
+ok( $llvm_lacking, "llvm reported as lacking: wrong output" );
+like(
+ $stdout,
+ qr/Could not get expected '--version' output for $exp/,
+ "Got expected verbose output: llvm lacking",
+);
+
+$output = undef;
+$llvm_lacking = 0;
+capture(
+ sub {
+ $llvm_lacking = auto::llvm::_handle_component_version_output(
+ $prog, $output, $llvm_lacking, $verbose
+ );
+ },
+ \$stdout,
+ \$stderr,
+);
+ok( $llvm_lacking, "llvm reported as lacking: output undefined" );
+like(
+ $stdout,
+ qr/Could not get expected '--version' output for $exp/,
+ "Got expected verbose output: llvm lacking",
+);
+
+##### _examine_llvm_gcc_version() #####
+
+$output = '';
+$llvm_lacking = 0;
+$verbose = 0;
+$llvm_lacking =
+ auto::llvm::_examine_llvm_gcc_version( $output, $llvm_lacking, $verbose );
+ok( $llvm_lacking, "_examine_llvm_gcc_version() reported LLVM lacking" );
+
+$output = 'foobar';
+$llvm_lacking = 0;
+$verbose = 0;
+$llvm_lacking =
+ auto::llvm::_examine_llvm_gcc_version( $output, $llvm_lacking, $verbose );
+ok( $llvm_lacking, "_examine_llvm_gcc_version() reported LLVM lacking" );
+
+$output = '3.2.1';
+$llvm_lacking = 0;
+$verbose = 0;
+$llvm_lacking =
+ auto::llvm::_examine_llvm_gcc_version( $output, $llvm_lacking, $verbose );
+ok( $llvm_lacking, "_examine_llvm_gcc_version() reported LLVM lacking" );
+
+$output = '4.2.1';
+$llvm_lacking = 0;
+$verbose = 0;
+$llvm_lacking =
+ auto::llvm::_examine_llvm_gcc_version( $output, $llvm_lacking, $verbose );
+ok( ! $llvm_lacking, "_examine_llvm_gcc_version() reported LLVM not lacking" );
+
+$output = 'foobar';
+$llvm_lacking = 0;
+$verbose = 1;
+capture(
+ sub { $llvm_lacking = auto::llvm::_examine_llvm_gcc_version(
+ $output, $llvm_lacking, $verbose ); },
+ \$stdout,
+ \$stderr,
+);
+ok( $llvm_lacking, "_examine_llvm_gcc_version() reported LLVM lacking" );
+like(
+ $stdout,
+ qr/Unable to extract llvm-gcc major, minor and patch versions/,
+ "Got expected verbose output from _examine_llvm_gcc_version()",
+);
+
+$output = '3.2.1';
+$llvm_lacking = 0;
+$verbose = 1;
+capture(
+ sub { $llvm_lacking = auto::llvm::_examine_llvm_gcc_version(
+ $output, $llvm_lacking, $verbose ); },
+ \$stdout,
+ \$stderr,
+);
+ok( $llvm_lacking, "_examine_llvm_gcc_version() reported LLVM lacking" );
+like(
+ $stdout,
+ qr/llvm-gcc must be at least major version 4/,
+ "Got expected verbose output from _examine_llvm_gcc_version()",
+);
+
+##### 4 methods #####
+$verbose = 0;
+
+$step->set_result( undef );
+$step->_handle_failure_to_compile_into_bitcode( $conf, $verbose );
+is( $step->result(), 'no', "Got expected result" );
+
+$step->set_result( undef );
+$step->_handle_failure_to_execute_bitcode( $conf, $verbose );
+is( $step->result(), 'no', "Got expected result" );
+
+$step->set_result( undef );
+$step->_handle_failure_to_compile_to_assembly( $conf, $verbose );
+is( $step->result(), 'no', "Got expected result" );
+
+$step->set_result( undef );
+$step->_handle_failure_to_assemble_assembly( $conf, $verbose );
+is( $step->result(), 'no', "Got expected result" );
+
+$verbose = 1;
+capture(
+ sub { $step->_handle_failure_to_compile_into_bitcode( $conf, $verbose ); },
+ \$stdout,
+ \$stderr,
+);
+like( $stdout,
+ qr/Unable to compile C file into LLVM bitcode file/,
+ "Got expected verbose output from _handle_failure_to_compile_into_bitcode()",
+);
+
+capture(
+ sub { $step->_handle_failure_to_execute_bitcode( $conf, $verbose ); },
+ \$stdout,
+ \$stderr,
+);
+like( $stdout,
+ qr/Unable to run LLVM bitcode file with 'lli'/,
+ "Got expected verbose output from _handle_failure_to_execute_bitcode()",
+);
+
+capture(
+ sub { $step->_handle_failure_to_compile_to_assembly( $conf, $verbose ); },
+ \$stdout,
+ \$stderr,
+);
+like( $stdout,
+ qr/Unable to compile program to native assembly using 'llc'/,
+ "Got expected verbose output from _handle_failure_to_compile_to_assembly()",
+);
+
+capture(
+ sub { $step->_handle_failure_to_assemble_assembly( $conf, $verbose ); },
+ \$stdout,
+ \$stderr,
+);
+like( $stdout,
+ qr/Unable to assemble native assembly into program/,
+ "Got expected verbose output from _handle_failure_to_assemble_assembly()",
+);
+
+##### _handle_native_assembly_output() #####
+
+{
+ local $@ = '';
+ $output = 'hello world';
+ $verbose = 0;
+ ok( $step->_handle_native_assembly_output( $conf, $output, $verbose ),
+ "_handle_native_assembly_output() returned true value" );
+ is( $step->result(), 'yes', "Got expected 'yes' result" );
+}
+
+{
+ local $@ = 'error';
+ $output = 'hello world';
+ $verbose = 0;
+ ok( $step->_handle_native_assembly_output( $conf, $output, $verbose ),
+ "_handle_native_assembly_output() returned true value" );
+ is( $step->result(), 'no', "Got expected 'no' result" );
+}
+
+{
+ local $@ = '';
+ $output = 'goodbye, cruel world';
+ $verbose = 0;
+ ok( $step->_handle_native_assembly_output( $conf, $output, $verbose ),
+ "_handle_native_assembly_output() returned true value" );
+ is( $step->result(), 'no', "Got expected 'no' result" );
+}
+
+{
+ local $@ = 'error';
+ $output = 'hello world';
+ $verbose = 1;
+ capture(
+ sub { $step->_handle_native_assembly_output(
+ $conf, $output, $verbose); },
+ \$stdout,
+ \$stderr,
+ );
+ is( $step->result(), 'no', "Got expected 'no' result" );
+ like(
+ $stdout,
+ qr/Unable to execute native assembly program successfully/,
+ "Got expected verbose output: native assembly program",
+ );
+}
+
+{
+ local $@ = '';
+ $output = 'goodbye, cruel world';
+ $verbose = 1;
+ capture(
+ sub { $step->_handle_native_assembly_output(
+ $conf, $output, $verbose); },
+ \$stdout,
+ \$stderr,
+ );
+ is( $step->result(), 'no', "Got expected 'no' result" );
+ like(
+ $stdout,
+ qr/Unable to execute native assembly program successfully/,
+ "Got expected verbose output: native assembly program",
+ );
+}
+
+##### _cleanup_llvm_files() #####
+
+my ( $bcfile, $sfile, $nativefile );
+my $count_unlinked;
+
+$count_unlinked =
+ auto::llvm::_cleanup_llvm_files( $bcfile, $sfile, $nativefile );
+is( $count_unlinked, 0, "no files existed, hence none unlinked" );
+
+( $bcfile, $sfile, $nativefile ) = ( '', '', '' );
+$count_unlinked =
+ auto::llvm::_cleanup_llvm_files( $bcfile, $sfile, $nativefile );
+is( $count_unlinked, 0, "no files existed, hence none unlinked" );
+
+{
+ my $tdir = tempdir( CLEANUP => 1 );
+ $bcfile = qq|$tdir/bcfile|;
+ open my $FH, '>', $bcfile
+ or die "Unable to open handle for writing: $!";
+ print $FH qq|bcfile hello world\n|;
+ close $FH or die "Unable to close handle after writing: $!";
+ $count_unlinked =
+ auto::llvm::_cleanup_llvm_files( $bcfile, $sfile, $nativefile );
+ is( $count_unlinked, 1, "one file existed, hence one unlinked" );
+}
+
+$conf->cc_clean();
+
+pass("Completed all tests in $0");
+
+################### DOCUMENTATION ###################
+
+=head1 NAME
+
+t/steps/auto/llvm-01.t - tests Parrot::Configure step auto::llvm
+
+=head1 SYNOPSIS
+
+ prove t/steps/auto/llvm-01.t
+
+=head1 DESCRIPTION
+
+This file holds tests for auto::llvm.
+
+=head1 AUTHOR
+
+James E Keenan
+
+=cut
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Modified: branches/html_cleanup/t/tools/dump_pbc.t
==============================================================================
--- branches/html_cleanup/t/tools/dump_pbc.t Wed Sep 1 02:19:14 2010 (r48747)
+++ branches/html_cleanup/t/tools/dump_pbc.t Wed Sep 1 06:33:06 2010 (r48748)
@@ -4,7 +4,7 @@
=head1 NAME
-t/tools/dumb_pbc.t - test the script tools/utils/dump_pbc.pl
+t/tools/dumb_pbc.t - test the script tools/dev/dump_pbc.pl
=head1 SYNOPSIS
@@ -34,7 +34,7 @@
my $PARROT = ".$PConfig{slash}$PConfig{test_prog}";
system( "$PARROT --output $pbc_fn $pir_fn" );
- my $cmd = File::Spec->catfile( qw{. tools util dump_pbc.pl} );
+ my $cmd = File::Spec->catfile( qw{. tools dev dump_pbc.pl} );
my $out = `$PConfig{perl} $cmd $pbc_fn`;
like( $out, $snippet, $desc );
Deleted: branches/html_cleanup/t/tools/pgegrep.t
==============================================================================
--- branches/html_cleanup/t/tools/pgegrep.t Wed Sep 1 06:33:06 2010 (r48747)
+++ /dev/null 00:00:00 1970 (deleted)
@@ -1,111 +0,0 @@
-#! perl
-# Copyright (C) 2009, Parrot Foundation.
-# $Id$
-
-=head1 NAME
-
-t/tools/pgegrep.t - test the script tools/utils/pgegrep
-
-=head1 SYNOPSIS
-
- % prove t/tools/pgegrep.t
-
-=head1 DESCRIPTION
-
-Tests the features of of the C<pgegrep> utility.
-
-=cut
-
-use strict;
-use warnings;
-use lib qw( . lib ../lib ../../lib );
-
-use Fatal qw{open close};
-use Test::More;
-use Parrot::Test tests => 10;
-use Parrot::Config;
-use File::Spec ();
-
-my $testdata = File::Spec->catfile(qw{. t tools testdata });
-my $testdata_escaped = $testdata;
-$testdata_escaped =~ s!\\!\\\\!g;
-
-sub pgegrep_output_like {
- my ($options, $snippet, $desc) = @_;
-
- my $PARROT = ".$PConfig{slash}$PConfig{test_prog}";
- my $pgegrep = File::Spec->catfile( qw{. tools util pgegrep} );
- my $out = `$PARROT $pgegrep $options`;
-
- like( $out, $snippet, $desc );
-
- return;
-}
-
-pgegrep_output_like(
- '-V',
- qr!\Qpgegrep v0.0.1\E!,
- 'pge reports correct version'
-);
-
-pgegrep_output_like(
- "cat $testdata",
- qr!keyboardcat!,
- 'basic sanity of matching a literal'
-);
-
-pgegrep_output_like(
- "-n cat $testdata",
- qr!1:keyboardcat!,
- 'matching a literal with line number'
-);
-
-pgegrep_output_like(
- "--line-number cat $testdata",
- qr!1:keyboardcat!,
- 'matching a literal with line number with long option'
-);
-
-pgegrep_output_like(
- "-H cat $testdata",
- qr!$testdata_escaped:keyboardcat!,
- 'matching a literal with file name'
-);
-
-pgegrep_output_like(
- "--with-filename cat $testdata",
- qr!$testdata_escaped:keyboardcat!,
- 'matching a literal with file name with long option'
-);
-
-
-pgegrep_output_like(
- "-v cat $testdata",
- qr!saxophonegiraffe!,
- 'test inversion of match'
-);
-
-pgegrep_output_like(
- "--invert-match cat $testdata",
- qr!saxophonegiraffe!,
- 'test inversion of match with long option'
-);
-
-pgegrep_output_like(
- "-l cat $testdata",
- qr!$testdata_escaped!,
- 'find files that match'
-);
-
-pgegrep_output_like(
- "--files-with-matches cat $testdata",
- qr!$testdata_escaped!,
- 'find files that match with long option'
-);
-
-# Local Variables:
-# mode: cperl
-# cperl-indent-level: 4
-# fill-column: 100
-# End:
-# vim: expandtab shiftwidth=4:
Copied: branches/html_cleanup/tools/build/README (from r48747, trunk/tools/build/README)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/build/README Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/build/README)
@@ -0,0 +1,13 @@
+# $Id$
+README for tools/build/
+
+This directory is intended to hold programs, templates and configuration files
+invoked by the default 'make' target ('make all'), with or without
+command-line options, during the Parrot build process.
+
+Programs, templates and configuration files invoked by 'make install' or
+'make install-dev' should be placed in tools/release/.
+
+Other things being equal, programs, templates and configuration files invoked
+by all other 'make' targets (e.g., 'make headerizer') should be placed in
+tools/dev/.
Deleted: branches/html_cleanup/tools/build/addopstags.pl
==============================================================================
--- branches/html_cleanup/tools/build/addopstags.pl Wed Sep 1 06:33:06 2010 (r48747)
+++ /dev/null 00:00:00 1970 (deleted)
@@ -1,54 +0,0 @@
-#!perl
-
-# Copyright (C) 2004-2006, Parrot Foundation.
-# $Id$
-
-use strict;
-use warnings;
-
-=head1 NAME
-
-tools/build/addopstags.pl - add src/ops/*.ops to tags
-
-=head1 SYNOPSIS
-
- perl tools/build/addopstags.pl src/ops/*.ops
-
-=head1 DESCRIPTION
-
-Add src/ops/*.ops to tags file.
-
-=cut
-
-my %seen;
-my @tags;
-
-# Pull ops tags
-while (<>) {
- if (/\bop \s+ (\w+) \s* \(/x) {
- next if $seen{$1}++;
-
- # tag file excmd xflags
- push @tags, join( "\t", $1, $ARGV, qq{$.;"}, "f" ) . "\n";
- }
-}
-continue {
- close ARGV if eof; # reset $.
-}
-
-# Pull existing tags
-open my $T, '<', 'tags';
-push @tags, <$T>;
-close $T;
-
-# Spit 'em out sorted
-open $T, '>', 'tags';
-print $T sort @tags;
-close $T;
-
-# Local Variables:
-# mode: cperl
-# cperl-indent-level: 4
-# fill-column: 100
-# End:
-# vim: expandtab shiftwidth=4:
Deleted: branches/html_cleanup/tools/build/headerizer.pl
==============================================================================
--- branches/html_cleanup/tools/build/headerizer.pl Wed Sep 1 06:33:06 2010 (r48747)
+++ /dev/null 00:00:00 1970 (deleted)
@@ -1,464 +0,0 @@
-#! perl
-# Copyright (C) 2001-2010, Parrot Foundation.
-# $Id$
-
-=head1 NAME
-
-tools/build/headerizer.pl - Generates the function header parts of .h
-files from .c files
-
-=head1 SYNOPSIS
-
- $ perl tools/build/headerizer.pl [object files]
-
-Generates C function declarations based on the function definitions in
-the C source code.
-
-=head1 DESCRIPTION
-
-The headerizer works off of directives in the source and header files.
-
-One source file's public declarations can only go into one header file.
-However, one header file can have declarations from multiple source files.
-In other words, headers-to-source is one-to-many.
-
-=over 4
-
-=item C<HEADERIZER BEGIN:> F<source-filename> / C<HEADERIZER END:> F<source-filename>
-
-Marks the beginning and end of a block of declarations in a header file.
-
- # In file foo.h
- /* HEADERIZER BEGIN: src/foo.c */
- /* HEADERIZER END: src/foo.c */
-
- /* HEADERIZER BEGIN: src/bar.c */
- /* HEADERIZER END: src/bar.c */
-
-=item C<HEADERIZER HFILE:> F<header-filename>
-
-Tells the headerizer where the declarations for the functions should go
-
- # In file foo.c
- /* HEADERIZER HFILE: foo.h */
-
- # In file bar.c
- /* HEADERIZER HFILE: foo.h */
-
-=back
-
-=head1 COMMAND-LINE OPTIONS
-
-=over 4
-
-=item C<--macro=X>
-
-Print a list of all functions that have macro X. For example, --macro=PARROT_EXPORT.
-
-=back
-
-=cut
-
-use strict;
-use warnings;
-
-use Getopt::Long;
-use lib qw( lib );
-use Parrot::Config;
-use Parrot::Headerizer;
-
-my $headerizer = Parrot::Headerizer->new;
-
-main();
-
-=head1 FUNCTIONS
-
-=head2 extract_function_declaration_and_update_source( $cfile_name )
-
-Extract all the function declarations from the C file specified by
-I<$cfile_name>, and update the comment blocks within.
-
-=cut
-
-sub extract_function_declarations_and_update_source {
- my $cfile_name = shift;
-
- open( my $fhin, '<', $cfile_name ) or die "Can't open $cfile_name: $!";
- my $text = join( '', <$fhin> );
- close $fhin;
-
- my @func_declarations = $headerizer->extract_function_declarations( $text );
- for my $decl ( @func_declarations ) {
- my $specs = $headerizer->function_components_from_declaration( $cfile_name, $decl );
- my $name = $specs->{name};
-
- my $heading = $headerizer->generate_documentation_signature($decl);
-
- $text =~ s/=item C<[^>]*\b$name\b[^>]*>\n+/$heading\n\n/sm or do {
- warn "$cfile_name: $name has no POD\n" unless $name =~ /^yy/; # lexer funcs don't have to have POD
- }
- }
- open( my $fhout, '>', $cfile_name ) or die "Can't create $cfile_name: $!";
- print {$fhout} $text;
- close $fhout;
-
- return @func_declarations;
-}
-
-
-sub attrs_from_args {
- my $func = shift;
- my @args = @_;
-
- my @attrs = ();
- my @mods = ();
-
- my $name = $func->{name};
- my $file = $func->{file};
- my $n = 0;
- for my $arg (@args) {
- ++$n;
- if ( $arg =~ m{ARG(?:MOD|OUT)(?:_NULLOK)?\((.+?)\)} ) {
- my $modified = $1;
- if ( $modified =~ s/.*\*/*/ ) {
- # We're OK
- }
- else {
- $modified =~ s/.* (\w+)$/$1/ or die qq{Unable to figure out the modified parm out of "$modified"};
- }
- push( @mods, "FUNC_MODIFIES($modified)" );
- }
- if ( $arg =~ m{(ARGIN|ARGOUT|ARGMOD|ARGFREE_NOTNULL|NOTNULL)\(} || $arg eq 'PARROT_INTERP' ) {
- push( @attrs, "__attribute__nonnull__($n)" );
- }
- if ( ( $arg =~ m{\*} ) && ( $arg !~ /\b(SHIM|((ARGIN|ARGOUT|ARGMOD)(_NULLOK)?)|ARGFREE(_NOTNULL)?)\b/ ) ) {
- if ( $name !~ /^yy/ ) { # Don't complain about the lexer auto-generated funcs
- $headerizer->squawk( $file, $name, qq{"$arg" isn't protected with an ARGIN, ARGOUT or ARGMOD (or a _NULLOK variant), or ARGFREE} );
- }
- }
- if ( ($arg =~ /\bconst\b/) && ($arg =~ /\*/) && ($arg !~ /\*\*/) && ($arg =~ /\b(ARG(MOD|OUT))\b/) ) {
- $headerizer->squawk( $file, $name, qq{"$arg" is const, but that $1 conflicts with const} );
- }
- }
-
- return (@attrs, at mods);
-}
-
-sub asserts_from_args {
- my @args = @_;
- my @asserts;
-
- for my $arg (@args) {
- if ( $arg =~ m{(ARGIN|ARGOUT|ARGMOD|ARGFREE_NOTNULL|NOTNULL)\((.+)\)} ) {
- my $var = $2;
- if($var =~ /\(*\s*([a-zA-Z_][a-zA-Z0-9_]*)\s*\)\s*\(/) {
- # argument is a function pointer
- $var = $1;
- }
- else {
- # try to isolate the variable's name;
- # strip off everything before the final space or asterisk.
- $var =~ s{.+[* ]([^* ]+)$}{$1};
- # strip off a trailing "[]", if any.
- $var =~ s{\[\]$}{};
- }
- push( @asserts, "PARROT_ASSERT_ARG($var)" );
- }
- if( $arg eq 'PARROT_INTERP' ) {
- push( @asserts, "PARROT_ASSERT_ARG(interp)" );
- }
- }
-
- return (@asserts);
-}
-
-sub make_function_decls {
- my @funcs = @_;
-
- my @decls;
- foreach my $func (@funcs) {
- my $multiline = 0;
-
- my $return = $func->{return_type};
- my $alt_void = ' ';
-
- # Splint can't handle /*@alt void@*/ on pointers, although this page
- # http://www.mail-archive.com/lclint-interest@virginia.edu/msg00139.html
- # seems to say that we can.
- if ( $func->{is_ignorable} && ($return !~ /\*/) ) {
- $alt_void = " /*\@alt void@*/\n";
- }
-
- my $decl = sprintf( "%s%s%s(", $return, $alt_void, $func->{name} );
- $decl = "static $decl" if $func->{is_static};
-
- my @args = @{ $func->{args} };
- my @attrs = attrs_from_args( $func, @args );
-
- for my $arg (@args) {
- if ( $arg =~ m{SHIM\((.+)\)} ) {
- $arg = $1;
- if ( $func->{is_static} || ( $arg =~ /\*/ ) ) {
- $arg = "SHIM($arg)";
- }
- else {
- $arg = "NULLOK($arg)";
- }
- }
- }
-
- my $argline = join( ", ", @args );
- if ( length( $decl . $argline ) <= 75 ) {
- $decl = "$decl$argline)";
- }
- else {
- if ( $args[0] =~ /^((SHIM|PARROT)_INTERP|Interp)\b/ ) {
- $decl .= ( shift @args );
- $decl .= "," if @args;
- }
- $argline = join( ",", map { "\n\t$_" } @args );
- $decl = "$decl$argline)";
- $multiline = 1;
- }
-
- my $attrs = join( "", map { "\n\t\t$_" } @attrs );
- if ($attrs) {
- $decl .= $attrs;
- $multiline = 1;
- }
- my @macros = @{ $func->{macros} };
- $multiline = 1 if @macros;
-
- $decl .= $multiline ? ";\n" : ";";
- $decl = join( "\n", @macros, $decl );
- $decl =~ s/\t/ /g;
- push( @decls, $decl );
- }
-
- foreach my $func (@funcs) {
- my @args = @{ $func->{args} };
- my @asserts = asserts_from_args( @args );
-
- my $assert = "#define ASSERT_ARGS_" . $func->{name};
- if(length($func->{name}) > 29) {
- $assert .= " \\\n ";
- }
- $assert .= " __attribute__unused__ int _ASSERT_ARGS_CHECK = (";
- if(@asserts) {
- $assert .= "\\\n ";
- $assert .= join(" \\\n , ", @asserts);
- }
- else {
- $assert .= "0";
- }
- $assert .= ")";
- push(@decls, $assert);
- }
-
- return @decls;
-}
-
-sub read_file {
- my $filename = shift;
-
- open my $fh, '<', $filename or die "couldn't read '$filename': $!";
- my $text = do { local $/ = undef; <$fh> };
- close $fh;
-
- return $text;
-}
-
-sub write_file {
- my $filename = shift;
- my $text = shift;
-
- open my $fh, '>', $filename or die "couldn't write '$filename': $!";
- print {$fh} $text;
- close $fh;
-}
-
-sub replace_headerized_declarations {
- my $source_code = shift;
- my $sourcefile = shift;
- my $hfile = shift;
- my @funcs = @_;
-
- # Allow a way to not headerize statics
- if ( $source_code =~ m{/\*\s*HEADERIZER NONE:\s*$sourcefile\s*\*/} ) {
- return $source_code;
- }
-
- @funcs = sort api_first_then_alpha @funcs;
-
- my @function_decls = make_function_decls(@funcs);
-
- my $function_decls = join( "\n", @function_decls );
- my $STARTMARKER = qr{/\* HEADERIZER BEGIN: $sourcefile \*/\n};
- my $ENDMARKER = qr{/\* HEADERIZER END: $sourcefile \*/\n?};
- my $DO_NOT_TOUCH = q{/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */};
-
- $source_code =~
- s{($STARTMARKER)(?:.*?)($ENDMARKER)}
- {$1$DO_NOT_TOUCH\n\n$function_decls\n$DO_NOT_TOUCH\n$2}s
- or die "Need begin/end HEADERIZER markers for $sourcefile in $hfile\n";
-
- return $source_code;
-}
-
-sub api_first_then_alpha {
- return ( ( $b->{is_api} || 0 ) <=> ( $a->{is_api} || 0 ) )
- || ( lc $a->{name} cmp lc $b->{name} );
-}
-
-sub main {
- my $macro_match;
- GetOptions(
- 'macro=s' => \$macro_match,
- ) or exit(1);
-
- die 'No files specified.' unless @ARGV;
- my %ofiles;
- ++$ofiles{$_} for @ARGV;
- my @ofiles = sort keys %ofiles;
- for (@ofiles) {
- print "$_ is specified more than once.\n" if $ofiles{$_} > 1;
- }
- my %sourcefiles;
- my %sourcefiles_with_statics;
- my %api;
-
- # Walk the object files and find corresponding source (either .c or .pmc)
- for my $ofile (@ofiles) {
- next if $ofile =~ m/^\Qsrc$PConfig{slash}ops\E/;
-
- $ofile =~ s/\\/\//g;
-
- my $is_yacc = ($ofile =~ /\.y$/);
- if ( !$is_yacc ) {
- my $sfile = $ofile;
- $sfile =~ s/\Q$PConfig{o}\E$/.s/;
- next if -f $sfile;
- }
-
- my $cfile = $ofile;
- $cfile =~ s/\Q$PConfig{o}\E$/.c/ or $is_yacc
- or die "$cfile doesn't look like an object file";
-
- my $pmcfile = $ofile;
- $pmcfile =~ s/\Q$PConfig{o}\E$/.pmc/;
-
- my $from_pmc = -f $pmcfile && !$is_yacc;
-
- my $sourcefile = $from_pmc ? $pmcfile : $cfile;
-
- my $source_code = read_file( $sourcefile );
- die qq{can't find HEADERIZER HFILE directive in "$sourcefile"}
- unless $source_code =~
- m{ /\* \s+ HEADERIZER\ HFILE: \s+ ([^*]+?) \s+ \*/ }sx;
-
- my $hfile = $1;
- if ( ( $hfile ne 'none' ) && ( not -f $hfile ) ) {
- die qq{"$hfile" not found (referenced from "$sourcefile")};
- }
-
- my @decls;
- if ( $macro_match ) {
- @decls = $headerizer->extract_function_declarations( $source_code );
- }
- else {
- @decls = extract_function_declarations_and_update_source( $sourcefile );
- }
-
- for my $decl (@decls) {
- my $components = $headerizer->function_components_from_declaration( $sourcefile, $decl );
- push( @{ $sourcefiles{$hfile}->{$sourcefile} }, $components ) unless $hfile eq 'none';
- push( @{ $sourcefiles_with_statics{$sourcefile} }, $components ) if $components->{is_static};
- if ( $macro_match ) {
- if ( grep { $_ eq $macro_match } @{$components->{macros}} ) {
- push( @{ $api{$sourcefile} }, $components );
- }
- }
- }
- } # for @cfiles
-
- if ( $macro_match ) {
- my $nfuncs = 0;
- for my $cfile ( sort keys %api ) {
- my @funcs = sort { $a->{name} cmp $b->{name} } @{$api{$cfile}};
- print "$cfile\n";
- for my $func ( @funcs ) {
- print " $func->{name}\n";
- ++$nfuncs;
- }
- }
- my $s = $nfuncs == 1 ? '' : 's';
- print "$nfuncs $macro_match function$s\n";
- }
- else { # Normal headerization and updating
- # Update all the .h files
- for my $hfile ( sort keys %sourcefiles ) {
- my $sourcefiles = $sourcefiles{$hfile};
-
- my $header = read_file($hfile);
-
- for my $cfile ( sort keys %{$sourcefiles} ) {
- my @funcs = @{ $sourcefiles->{$cfile} };
- @funcs = grep { not $_->{is_static} } @funcs; # skip statics
-
- $header = replace_headerized_declarations( $header, $cfile, $hfile, @funcs );
- }
-
- write_file( $hfile, $header );
- }
-
- # Update all the .c files in place
- for my $cfile ( sort keys %sourcefiles_with_statics ) {
- my @funcs = @{ $sourcefiles_with_statics{$cfile} };
- @funcs = grep { $_->{is_static} } @funcs;
-
- my $source = read_file($cfile);
- $source = replace_headerized_declarations( $source, 'static', $cfile, @funcs );
-
- write_file( $cfile, $source );
- }
- print "Headerization complete.\n";
- }
-
- my %warnings = %{$headerizer->{warnings}};
- if ( keys %warnings ) {
- my $nwarnings = 0;
- my $nwarningfuncs = 0;
- my $nwarningfiles = 0;
- for my $file ( sort keys %warnings ) {
- ++$nwarningfiles;
- print "$file\n";
- my $funcs = $warnings{$file};
- for my $func ( sort keys %{$funcs} ) {
- ++$nwarningfuncs;
- for my $error ( @{ $funcs->{$func} } ) {
- print " $func: $error\n";
- ++$nwarnings;
- }
- }
- }
-
- print "$nwarnings warnings in $nwarningfuncs funcs in $nwarningfiles C files\n";
- }
-
- return;
-}
-
-# From earlier documentation:
-# * Generate docs from funcs
-# * Somehow handle static functions in the source file
-# * the .c files MUST have a /* HEADERIZER HFILE: foo/bar.h */ directive in them
-# * Support for multiple .c files pointing at the same .h file
-# * Does NOT remove all blocks in the .h file, so if a .c file
-# disappears, its block is "orphaned" and will remain there.
-
-# Local Variables:
-# mode: cperl
-# cperl-indent-level: 4
-# fill-column: 100
-# End:
-# vim: expandtab shiftwidth=4:
Copied: branches/html_cleanup/tools/dev/README (from r48747, trunk/tools/dev/README)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/dev/README Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/dev/README)
@@ -0,0 +1,7 @@
+# $Id$
+README for tools/dev/
+
+This directory is intended to hold programs, templates and configuration files
+found useful by Parrot developed other than those (a) invoked by the default
+'make' target ('make all'), with or without command-line options, during the
+Parrot build process; or (b) invoked by 'make install' or 'make install-dev'.
Copied: branches/html_cleanup/tools/dev/addopstags.pl (from r48747, trunk/tools/dev/addopstags.pl)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/dev/addopstags.pl Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/dev/addopstags.pl)
@@ -0,0 +1,54 @@
+#!perl
+
+# Copyright (C) 2004-2006, Parrot Foundation.
+# $Id$
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+tools/dev/addopstags.pl - add src/ops/*.ops to tags
+
+=head1 SYNOPSIS
+
+ perl tools/dev/addopstags.pl src/ops/*.ops
+
+=head1 DESCRIPTION
+
+Add src/ops/*.ops to tags file.
+
+=cut
+
+my %seen;
+my @tags;
+
+# Pull ops tags
+while (<>) {
+ if (/\bop \s+ (\w+) \s* \(/x) {
+ next if $seen{$1}++;
+
+ # tag file excmd xflags
+ push @tags, join( "\t", $1, $ARGV, qq{$.;"}, "f" ) . "\n";
+ }
+}
+continue {
+ close ARGV if eof; # reset $.
+}
+
+# Pull existing tags
+open my $T, '<', 'tags';
+push @tags, <$T>;
+close $T;
+
+# Spit 'em out sorted
+open $T, '>', 'tags';
+print $T sort @tags;
+close $T;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Copied: branches/html_cleanup/tools/dev/dump_pbc.pl (from r48747, trunk/tools/dev/dump_pbc.pl)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/dev/dump_pbc.pl Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/dev/dump_pbc.pl)
@@ -0,0 +1,125 @@
+#! perl
+
+# Copyright (C) 2008, Parrot Foundation.
+# $Id$
+
+=head1 NAME
+
+tools/dev/dump_pbc.pl - Weave together PBC disassembly with PIR source
+
+=head1 SYNOPSIS
+
+ perl tools/dev/dump_pbc.pl foo.pbc
+
+=head1 DESCRIPTION
+
+dump_pbc.pl uses Parrot's F<pbc_disassemble> program to disassemble the opcodes
+in a PBC (Parrot ByteCode) file, then weaves the disassembly together with
+the original PIR source file(s). This makes it easier to see how the PIR
+syntactic sugar is desugared into raw Parrot opcodes.
+
+=head1 BUGS
+
+This program has only been tested for a few simple cases. Also, the name
+might suggest a different use than its actual purpose.
+
+While it is not a bug in F<dump_pbc.pl> per se, there is a line numbering
+bug for some PBC opcode sequences that will result in the disassembled
+opcodes appearing just before the source lines they represent, rather
+than just after. There does not appear to be consensus yet about where
+this bug actually resides.
+
+=cut
+
+use strict;
+use warnings;
+use Cwd;
+use FindBin;
+
+my ($PARROT_ROOT, $RUNTIME_DIR);
+BEGIN {
+ $PARROT_ROOT = Cwd::abs_path("$FindBin::Bin/../..");
+ $RUNTIME_DIR = "$PARROT_ROOT/runtime/parrot";
+}
+
+use lib "$PARROT_ROOT/lib";
+use Parrot::Config '%PConfig';
+
+my $DISASSEMBLER = "$PConfig{build_dir}$PConfig{slash}pbc_disassemble$PConfig{exe}";
+
+go(@ARGV);
+
+sub go {
+ my $pbc = shift;
+
+ # The following mess brought to you by Win32, where pipe open doesn't work,
+ # and thus its greater security and cleaner error handling are unavailable.
+
+ -f $pbc && -r _
+ or die "PBC file '$pbc' does not exist or is not readable.\n";
+
+ -f $DISASSEMBLER && -x _
+ or die "Can't find disassembler '$DISASSEMBLER';"
+ . "did you remember to make parrot first?\n";
+
+ my @dis = `$DISASSEMBLER $pbc`;
+ die "No disassembly; errors: $?, $!" unless @dis;
+
+ my $cur_file = '';
+ my $cur_line = -1;
+ my %cache;
+
+ foreach (@dis) {
+ if (/^(?:# )?Current Source Filename (.*)/) {
+ my $found = $1;
+ $found =~ s/^'//;
+ $found =~ s/'$//;
+ if ($cur_file ne $found) {
+ $cur_file = $found;
+ $cache{$cur_file} ||= slurp_file($cur_file);
+ $cur_line = -1;
+
+ print "\n#### $cur_file\n";
+ }
+ }
+ elsif (my ($info, $seq, $pc, $line, $code) = /^((\d+)-(\d+) (\d+): )(.*)/) {
+ my $int_line = int $line;
+ my $len_line = length $line;
+ if ($cur_line != $int_line) {
+ $cur_line = 0 if $cur_line == -1;
+ print "\n";
+ foreach my $i ($cur_line + 1 .. $int_line) {
+ my $source_code = $cache{$cur_file}[$i-1];
+ # next unless $source_code =~ /\S/;
+ printf "# %*d: %s", $len_line, $i, $source_code;
+ print "\n" if $source_code =~ /^\.end/;
+ }
+ $cur_line = $int_line;
+ }
+
+ print ' ' x ($len_line + 4), "$code\n";
+ }
+ }
+}
+
+sub slurp_file {
+ my $file = shift;
+ my $source;
+
+ open $source, '<', $file
+ or open $source, '<', "$PARROT_ROOT/$file"
+ or open $source, '<', "$RUNTIME_DIR/$file"
+ or die "Could not open source file '$file': $!";
+
+ my @lines = <$source>;
+
+ return \@lines;
+}
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Copied: branches/html_cleanup/tools/dev/headerizer.pl (from r48747, trunk/tools/dev/headerizer.pl)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/dev/headerizer.pl Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/dev/headerizer.pl)
@@ -0,0 +1,464 @@
+#! perl
+# Copyright (C) 2001-2010, Parrot Foundation.
+# $Id$
+
+=head1 NAME
+
+tools/dev/headerizer.pl - Generates the function header parts of .h
+files from .c files
+
+=head1 SYNOPSIS
+
+ $ perl tools/dev/headerizer.pl [object files]
+
+Generates C function declarations based on the function definitions in
+the C source code.
+
+=head1 DESCRIPTION
+
+The headerizer works off of directives in the source and header files.
+
+One source file's public declarations can only go into one header file.
+However, one header file can have declarations from multiple source files.
+In other words, headers-to-source is one-to-many.
+
+=over 4
+
+=item C<HEADERIZER BEGIN:> F<source-filename> / C<HEADERIZER END:> F<source-filename>
+
+Marks the beginning and end of a block of declarations in a header file.
+
+ # In file foo.h
+ /* HEADERIZER BEGIN: src/foo.c */
+ /* HEADERIZER END: src/foo.c */
+
+ /* HEADERIZER BEGIN: src/bar.c */
+ /* HEADERIZER END: src/bar.c */
+
+=item C<HEADERIZER HFILE:> F<header-filename>
+
+Tells the headerizer where the declarations for the functions should go
+
+ # In file foo.c
+ /* HEADERIZER HFILE: foo.h */
+
+ # In file bar.c
+ /* HEADERIZER HFILE: foo.h */
+
+=back
+
+=head1 COMMAND-LINE OPTIONS
+
+=over 4
+
+=item C<--macro=X>
+
+Print a list of all functions that have macro X. For example, --macro=PARROT_EXPORT.
+
+=back
+
+=cut
+
+use strict;
+use warnings;
+
+use Getopt::Long;
+use lib qw( lib );
+use Parrot::Config;
+use Parrot::Headerizer;
+
+my $headerizer = Parrot::Headerizer->new;
+
+main();
+
+=head1 FUNCTIONS
+
+=head2 extract_function_declaration_and_update_source( $cfile_name )
+
+Extract all the function declarations from the C file specified by
+I<$cfile_name>, and update the comment blocks within.
+
+=cut
+
+sub extract_function_declarations_and_update_source {
+ my $cfile_name = shift;
+
+ open( my $fhin, '<', $cfile_name ) or die "Can't open $cfile_name: $!";
+ my $text = join( '', <$fhin> );
+ close $fhin;
+
+ my @func_declarations = $headerizer->extract_function_declarations( $text );
+ for my $decl ( @func_declarations ) {
+ my $specs = $headerizer->function_components_from_declaration( $cfile_name, $decl );
+ my $name = $specs->{name};
+
+ my $heading = $headerizer->generate_documentation_signature($decl);
+
+ $text =~ s/=item C<[^>]*\b$name\b[^>]*>\n+/$heading\n\n/sm or do {
+ warn "$cfile_name: $name has no POD\n" unless $name =~ /^yy/; # lexer funcs don't have to have POD
+ }
+ }
+ open( my $fhout, '>', $cfile_name ) or die "Can't create $cfile_name: $!";
+ print {$fhout} $text;
+ close $fhout;
+
+ return @func_declarations;
+}
+
+
+sub attrs_from_args {
+ my $func = shift;
+ my @args = @_;
+
+ my @attrs = ();
+ my @mods = ();
+
+ my $name = $func->{name};
+ my $file = $func->{file};
+ my $n = 0;
+ for my $arg (@args) {
+ ++$n;
+ if ( $arg =~ m{ARG(?:MOD|OUT)(?:_NULLOK)?\((.+?)\)} ) {
+ my $modified = $1;
+ if ( $modified =~ s/.*\*/*/ ) {
+ # We're OK
+ }
+ else {
+ $modified =~ s/.* (\w+)$/$1/ or die qq{Unable to figure out the modified parm out of "$modified"};
+ }
+ push( @mods, "FUNC_MODIFIES($modified)" );
+ }
+ if ( $arg =~ m{(ARGIN|ARGOUT|ARGMOD|ARGFREE_NOTNULL|NOTNULL)\(} || $arg eq 'PARROT_INTERP' ) {
+ push( @attrs, "__attribute__nonnull__($n)" );
+ }
+ if ( ( $arg =~ m{\*} ) && ( $arg !~ /\b(SHIM|((ARGIN|ARGOUT|ARGMOD)(_NULLOK)?)|ARGFREE(_NOTNULL)?)\b/ ) ) {
+ if ( $name !~ /^yy/ ) { # Don't complain about the lexer auto-generated funcs
+ $headerizer->squawk( $file, $name, qq{"$arg" isn't protected with an ARGIN, ARGOUT or ARGMOD (or a _NULLOK variant), or ARGFREE} );
+ }
+ }
+ if ( ($arg =~ /\bconst\b/) && ($arg =~ /\*/) && ($arg !~ /\*\*/) && ($arg =~ /\b(ARG(MOD|OUT))\b/) ) {
+ $headerizer->squawk( $file, $name, qq{"$arg" is const, but that $1 conflicts with const} );
+ }
+ }
+
+ return (@attrs, at mods);
+}
+
+sub asserts_from_args {
+ my @args = @_;
+ my @asserts;
+
+ for my $arg (@args) {
+ if ( $arg =~ m{(ARGIN|ARGOUT|ARGMOD|ARGFREE_NOTNULL|NOTNULL)\((.+)\)} ) {
+ my $var = $2;
+ if($var =~ /\(*\s*([a-zA-Z_][a-zA-Z0-9_]*)\s*\)\s*\(/) {
+ # argument is a function pointer
+ $var = $1;
+ }
+ else {
+ # try to isolate the variable's name;
+ # strip off everything before the final space or asterisk.
+ $var =~ s{.+[* ]([^* ]+)$}{$1};
+ # strip off a trailing "[]", if any.
+ $var =~ s{\[\]$}{};
+ }
+ push( @asserts, "PARROT_ASSERT_ARG($var)" );
+ }
+ if( $arg eq 'PARROT_INTERP' ) {
+ push( @asserts, "PARROT_ASSERT_ARG(interp)" );
+ }
+ }
+
+ return (@asserts);
+}
+
+sub make_function_decls {
+ my @funcs = @_;
+
+ my @decls;
+ foreach my $func (@funcs) {
+ my $multiline = 0;
+
+ my $return = $func->{return_type};
+ my $alt_void = ' ';
+
+ # Splint can't handle /*@alt void@*/ on pointers, although this page
+ # http://www.mail-archive.com/lclint-interest@virginia.edu/msg00139.html
+ # seems to say that we can.
+ if ( $func->{is_ignorable} && ($return !~ /\*/) ) {
+ $alt_void = " /*\@alt void@*/\n";
+ }
+
+ my $decl = sprintf( "%s%s%s(", $return, $alt_void, $func->{name} );
+ $decl = "static $decl" if $func->{is_static};
+
+ my @args = @{ $func->{args} };
+ my @attrs = attrs_from_args( $func, @args );
+
+ for my $arg (@args) {
+ if ( $arg =~ m{SHIM\((.+)\)} ) {
+ $arg = $1;
+ if ( $func->{is_static} || ( $arg =~ /\*/ ) ) {
+ $arg = "SHIM($arg)";
+ }
+ else {
+ $arg = "NULLOK($arg)";
+ }
+ }
+ }
+
+ my $argline = join( ", ", @args );
+ if ( length( $decl . $argline ) <= 75 ) {
+ $decl = "$decl$argline)";
+ }
+ else {
+ if ( $args[0] =~ /^((SHIM|PARROT)_INTERP|Interp)\b/ ) {
+ $decl .= ( shift @args );
+ $decl .= "," if @args;
+ }
+ $argline = join( ",", map { "\n\t$_" } @args );
+ $decl = "$decl$argline)";
+ $multiline = 1;
+ }
+
+ my $attrs = join( "", map { "\n\t\t$_" } @attrs );
+ if ($attrs) {
+ $decl .= $attrs;
+ $multiline = 1;
+ }
+ my @macros = @{ $func->{macros} };
+ $multiline = 1 if @macros;
+
+ $decl .= $multiline ? ";\n" : ";";
+ $decl = join( "\n", @macros, $decl );
+ $decl =~ s/\t/ /g;
+ push( @decls, $decl );
+ }
+
+ foreach my $func (@funcs) {
+ my @args = @{ $func->{args} };
+ my @asserts = asserts_from_args( @args );
+
+ my $assert = "#define ASSERT_ARGS_" . $func->{name};
+ if(length($func->{name}) > 29) {
+ $assert .= " \\\n ";
+ }
+ $assert .= " __attribute__unused__ int _ASSERT_ARGS_CHECK = (";
+ if(@asserts) {
+ $assert .= "\\\n ";
+ $assert .= join(" \\\n , ", @asserts);
+ }
+ else {
+ $assert .= "0";
+ }
+ $assert .= ")";
+ push(@decls, $assert);
+ }
+
+ return @decls;
+}
+
+sub read_file {
+ my $filename = shift;
+
+ open my $fh, '<', $filename or die "couldn't read '$filename': $!";
+ my $text = do { local $/ = undef; <$fh> };
+ close $fh;
+
+ return $text;
+}
+
+sub write_file {
+ my $filename = shift;
+ my $text = shift;
+
+ open my $fh, '>', $filename or die "couldn't write '$filename': $!";
+ print {$fh} $text;
+ close $fh;
+}
+
+sub replace_headerized_declarations {
+ my $source_code = shift;
+ my $sourcefile = shift;
+ my $hfile = shift;
+ my @funcs = @_;
+
+ # Allow a way to not headerize statics
+ if ( $source_code =~ m{/\*\s*HEADERIZER NONE:\s*$sourcefile\s*\*/} ) {
+ return $source_code;
+ }
+
+ @funcs = sort api_first_then_alpha @funcs;
+
+ my @function_decls = make_function_decls(@funcs);
+
+ my $function_decls = join( "\n", @function_decls );
+ my $STARTMARKER = qr{/\* HEADERIZER BEGIN: $sourcefile \*/\n};
+ my $ENDMARKER = qr{/\* HEADERIZER END: $sourcefile \*/\n?};
+ my $DO_NOT_TOUCH = q{/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */};
+
+ $source_code =~
+ s{($STARTMARKER)(?:.*?)($ENDMARKER)}
+ {$1$DO_NOT_TOUCH\n\n$function_decls\n$DO_NOT_TOUCH\n$2}s
+ or die "Need begin/end HEADERIZER markers for $sourcefile in $hfile\n";
+
+ return $source_code;
+}
+
+sub api_first_then_alpha {
+ return ( ( $b->{is_api} || 0 ) <=> ( $a->{is_api} || 0 ) )
+ || ( lc $a->{name} cmp lc $b->{name} );
+}
+
+sub main {
+ my $macro_match;
+ GetOptions(
+ 'macro=s' => \$macro_match,
+ ) or exit(1);
+
+ die 'No files specified.' unless @ARGV;
+ my %ofiles;
+ ++$ofiles{$_} for @ARGV;
+ my @ofiles = sort keys %ofiles;
+ for (@ofiles) {
+ print "$_ is specified more than once.\n" if $ofiles{$_} > 1;
+ }
+ my %sourcefiles;
+ my %sourcefiles_with_statics;
+ my %api;
+
+ # Walk the object files and find corresponding source (either .c or .pmc)
+ for my $ofile (@ofiles) {
+ next if $ofile =~ m/^\Qsrc$PConfig{slash}ops\E/;
+
+ $ofile =~ s/\\/\//g;
+
+ my $is_yacc = ($ofile =~ /\.y$/);
+ if ( !$is_yacc ) {
+ my $sfile = $ofile;
+ $sfile =~ s/\Q$PConfig{o}\E$/.s/;
+ next if -f $sfile;
+ }
+
+ my $cfile = $ofile;
+ $cfile =~ s/\Q$PConfig{o}\E$/.c/ or $is_yacc
+ or die "$cfile doesn't look like an object file";
+
+ my $pmcfile = $ofile;
+ $pmcfile =~ s/\Q$PConfig{o}\E$/.pmc/;
+
+ my $from_pmc = -f $pmcfile && !$is_yacc;
+
+ my $sourcefile = $from_pmc ? $pmcfile : $cfile;
+
+ my $source_code = read_file( $sourcefile );
+ die qq{can't find HEADERIZER HFILE directive in "$sourcefile"}
+ unless $source_code =~
+ m{ /\* \s+ HEADERIZER\ HFILE: \s+ ([^*]+?) \s+ \*/ }sx;
+
+ my $hfile = $1;
+ if ( ( $hfile ne 'none' ) && ( not -f $hfile ) ) {
+ die qq{"$hfile" not found (referenced from "$sourcefile")};
+ }
+
+ my @decls;
+ if ( $macro_match ) {
+ @decls = $headerizer->extract_function_declarations( $source_code );
+ }
+ else {
+ @decls = extract_function_declarations_and_update_source( $sourcefile );
+ }
+
+ for my $decl (@decls) {
+ my $components = $headerizer->function_components_from_declaration( $sourcefile, $decl );
+ push( @{ $sourcefiles{$hfile}->{$sourcefile} }, $components ) unless $hfile eq 'none';
+ push( @{ $sourcefiles_with_statics{$sourcefile} }, $components ) if $components->{is_static};
+ if ( $macro_match ) {
+ if ( grep { $_ eq $macro_match } @{$components->{macros}} ) {
+ push( @{ $api{$sourcefile} }, $components );
+ }
+ }
+ }
+ } # for @cfiles
+
+ if ( $macro_match ) {
+ my $nfuncs = 0;
+ for my $cfile ( sort keys %api ) {
+ my @funcs = sort { $a->{name} cmp $b->{name} } @{$api{$cfile}};
+ print "$cfile\n";
+ for my $func ( @funcs ) {
+ print " $func->{name}\n";
+ ++$nfuncs;
+ }
+ }
+ my $s = $nfuncs == 1 ? '' : 's';
+ print "$nfuncs $macro_match function$s\n";
+ }
+ else { # Normal headerization and updating
+ # Update all the .h files
+ for my $hfile ( sort keys %sourcefiles ) {
+ my $sourcefiles = $sourcefiles{$hfile};
+
+ my $header = read_file($hfile);
+
+ for my $cfile ( sort keys %{$sourcefiles} ) {
+ my @funcs = @{ $sourcefiles->{$cfile} };
+ @funcs = grep { not $_->{is_static} } @funcs; # skip statics
+
+ $header = replace_headerized_declarations( $header, $cfile, $hfile, @funcs );
+ }
+
+ write_file( $hfile, $header );
+ }
+
+ # Update all the .c files in place
+ for my $cfile ( sort keys %sourcefiles_with_statics ) {
+ my @funcs = @{ $sourcefiles_with_statics{$cfile} };
+ @funcs = grep { $_->{is_static} } @funcs;
+
+ my $source = read_file($cfile);
+ $source = replace_headerized_declarations( $source, 'static', $cfile, @funcs );
+
+ write_file( $cfile, $source );
+ }
+ print "Headerization complete.\n";
+ }
+
+ my %warnings = %{$headerizer->{warnings}};
+ if ( keys %warnings ) {
+ my $nwarnings = 0;
+ my $nwarningfuncs = 0;
+ my $nwarningfiles = 0;
+ for my $file ( sort keys %warnings ) {
+ ++$nwarningfiles;
+ print "$file\n";
+ my $funcs = $warnings{$file};
+ for my $func ( sort keys %{$funcs} ) {
+ ++$nwarningfuncs;
+ for my $error ( @{ $funcs->{$func} } ) {
+ print " $func: $error\n";
+ ++$nwarnings;
+ }
+ }
+ }
+
+ print "$nwarnings warnings in $nwarningfuncs funcs in $nwarningfiles C files\n";
+ }
+
+ return;
+}
+
+# From earlier documentation:
+# * Generate docs from funcs
+# * Somehow handle static functions in the source file
+# * the .c files MUST have a /* HEADERIZER HFILE: foo/bar.h */ directive in them
+# * Support for multiple .c files pointing at the same .h file
+# * Does NOT remove all blocks in the .h file, so if a .c file
+# disappears, its block is "orphaned" and will remain there.
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Copied: branches/html_cleanup/tools/dev/ncidef2pasm.pl (from r48747, trunk/tools/dev/ncidef2pasm.pl)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/dev/ncidef2pasm.pl Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/dev/ncidef2pasm.pl)
@@ -0,0 +1,237 @@
+#! perl
+
+# Copyright (C) 2003-2007, Parrot Foundation.
+# $Id$
+
+=head1 NAME
+
+tools/dev/ncidef2asm.pl - Turn an NCI library definition file into PASM
+
+=head1 SYNOPSIS
+
+ perl tools/dev/ncidef2asm.pl path/to/from_file [ path/to/to_file ]
+
+=head1 DESCRIPTION
+
+This program takes an NCI library definition file and turns it into PASM.
+
+An NCI library definition file provides the information needed to
+generate a parrot wrapper for the named library (or libraries). Its
+format is simple, and looks like:
+
+ [package]
+ ncurses
+
+ [lib]
+ libform.so
+
+ [defs]
+ p new_field i i i i i i
+
+ [lib]
+ libncurses.so
+
+ [defs]
+ i is_term_resized i i
+
+Note that the assembly file is generated in the order you specify, so
+if there are library dependencies, make sure you have them in the
+correct order.
+
+=head2 package
+
+Declares the package that all subsequent sub PMCs will be put
+into. The name is a simple concatenation of the package name, double
+colon, and the routine name, with no preceding punctuation.
+
+=head2 lib
+
+The name of the library to be loaded. Should be as qualified as
+necessary for your platform--generally the full filename is required,
+though the directory generally isn't.
+
+You may load multiple libraries here, but only the last one loaded
+will be exposed to subsequent defs.
+
+=head2 defs
+
+This section holds the definitions of functions. Each function is
+assumed to be in the immediate preceding library. The definition of
+the function is:
+
+ return_type name [param [param [param ...]]]
+
+The param and return_type parameters use the NCI standard, which for
+reference is:
+
+=over 4
+
+=item p
+
+Parameter is a void pointer, taken from the PMC's data pointer. PMC is
+assumed to be an unmanagedstruct or child class.
+
+Taken from a P register
+
+=item c
+
+Parameter is a character.
+
+Taken from an I register
+
+=item s
+
+Parameter is a short
+
+Taken from an I register
+
+=item i
+
+Parameter is an int
+
+Taken from an I register
+
+=item l
+
+Parameter is a long
+
+Taken from an I register
+
+=item f
+
+Paramter is a float
+
+Taken from an N register.
+
+=item d
+
+Parameter is a double.
+
+Taken from an N register.
+
+=item t
+
+Paramter is a char *, presumably a C string
+
+Taken from an S register
+
+=item v
+
+Void. Only valid as a return type, noting that the function returns no data.
+
+=item I
+
+Interpreter pointer. The current interpreter pointer is passed in
+
+=item P
+
+PMC.
+
+=item 2
+
+Pointer to short.
+
+Taken from an I register.
+
+=item 3
+
+Pointer to int.
+
+Taken from an I register
+
+=item 4
+
+Pointer to long
+
+Taken from an I register
+
+=back
+
+=cut
+
+use strict;
+use warnings;
+
+my ( $from_file, $to_file ) = @ARGV;
+
+# If there is no destination file, strip off the extension of the
+# source file and add a .pasm to it
+if ( !defined $to_file ) {
+ $to_file = $from_file;
+ $to_file =~ s/\..*$//;
+ $to_file .= ".pasm";
+}
+
+open my $INPUT, '<', "$from_file" or die "Can't open up $from_file, error $!";
+open my $OUTPUT, '>', "$to_file" or die "Can't open up $to_file, error $!";
+
+# To start, save all the registers, just in case
+print $OUTPUT "saveall\n";
+
+my @libs;
+my ( $cur_package, $line, $cur_section );
+
+# Our dispatch table
+my (%dispatch) = (
+ package => \&package_line,
+ lib => \&lib_line,
+ defs => \&def_line,
+);
+
+while ( $line = <$INPUT> ) {
+
+ # Throw away trailing newlines, comments, and whitespace. If the
+ # line's empty, then off to the next line
+ chomp $line;
+ $line =~ s/#.*//;
+ $line =~ s/\s*$//;
+ next unless $line;
+
+ # Is it a section line? If so, extract the section and set it.
+ if ( $line =~ /\[(\w+)\]/ ) {
+ $cur_section = $1;
+ next;
+ }
+
+ # Everything else goes to the handler
+ $dispatch{$cur_section}->($line);
+
+}
+
+# Put the registers back and end
+print $OUTPUT "restoreall\n";
+print $OUTPUT "end\n";
+close $OUTPUT;
+
+sub package_line {
+ my $line = shift;
+
+ # Trim leading and trailing spaces
+ $line =~ s/^\s*//;
+ $line =~ s/\s*$//;
+
+ # Set the global current package
+ $cur_package = $line;
+
+}
+
+sub lib_line {
+ my $line = shift;
+ print $OUTPUT "loadlib P1, '$line'\n";
+}
+
+sub def_line {
+ my $line = shift;
+ my ( $return_type, $name, @params ) = split ' ', $line;
+ unshift @params, $return_type;
+ my $signature = join( "", @params );
+ print $OUTPUT "dlfunc P2, P1, '$name', '$signature'\n";
+ print $OUTPUT "store_global '${cur_package}::${name}', P2\n";
+}
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Copied: branches/html_cleanup/tools/dev/parrot-config.pir (from r48747, trunk/tools/dev/parrot-config.pir)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/dev/parrot-config.pir Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/dev/parrot-config.pir)
@@ -0,0 +1,103 @@
+#!/usr/bin/env parrot
+# $Id$
+
+=head1 NAME
+
+config.pir - Print a Parrot configuration item
+
+=head1 VERSION
+
+version 0.01
+
+=head1 SYNOPSIS
+
+ ./parrot parrot-config.pir VERSION
+ ./parrot parrot-config.pir ccflags
+ ./parrot parrot-config.pir --dump
+
+=head1 DESCRIPTION
+
+Print out configuration items.
+
+=head1 AUTHOR
+
+Leopold Toetsch E<lt>lt at toetsch.atE<gt>.
+
+=head1 COPYRIGHT
+
+Copyright (C) 2004-2009, Parrot Foundation.
+
+=cut
+
+.sub _main :main
+ .param pmc argv
+ .local int argc
+ argc = argv
+ if argc < 2 goto usage
+ .local pmc interp, conf_hash
+ .local string key
+ .include "iglobals.pasm"
+ interp = getinterp
+ conf_hash = interp[.IGLOBALS_CONFIG_HASH]
+ .local int i
+ i = 1
+loop:
+ key = argv[i]
+ if key == '--help' goto usage
+ if key == '--dump' goto dump
+ $I0 = defined conf_hash[key]
+ unless $I0 goto failkey
+ dec argc
+ if i < argc goto dumpsome
+ $S0 = conf_hash[key]
+ print $S0
+ inc i
+ if i < argc goto loop
+ print "\n"
+ end
+dumpsome:
+ key = argv[i]
+ $I0 = defined conf_hash[key]
+ unless $I0 goto failkey
+ print key
+ print " => '"
+ $S1 = conf_hash[key]
+ print $S1
+ say "'"
+ inc i
+ if i <= argc goto dumpsome
+ end
+failkey:
+ print " no such key: '"
+ print key
+ print "'\n"
+ end
+dump:
+ .local pmc iterator
+ iterator = iter conf_hash
+iter_loop:
+ unless iterator goto iter_end
+ shift $S0, iterator
+ print $S0
+ print " => '"
+ $S1 = conf_hash[$S0]
+ print $S1
+ say "'"
+ goto iter_loop
+iter_end:
+ end
+usage:
+ $S0 = argv[0]
+ $P0 = getinterp
+ .include 'stdio.pasm'
+ $P1 = $P0.'stdhandle'(.PIO_STDERR_FILENO)
+ $P1.'print'($S0)
+ $P1.'print'(" [ <config-key> [ <config-key> ... ] | --dump | --help ]\n")
+ exit 1
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Copied: branches/html_cleanup/tools/dev/perlcritic-cage.conf (from r48747, trunk/tools/dev/perlcritic-cage.conf)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/dev/perlcritic-cage.conf Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/dev/perlcritic-cage.conf)
@@ -0,0 +1,37 @@
+# A more stringent set of rules for cage cleaners
+
+[-CodeLayout::ProhibitParensWithBuiltins]
+[CodeLayout::ProhibitHardTabs]
+allow_leading_tabs = 0
+
+[-CodeLayout::RequireTidyCode]
+
+[-ControlStructures::ProhibitPostfixControls]
+[-ControlStructures::ProhibitUnlessBlocks]
+
+[-Documentation::PodSpelling]
+[-Documentation::RequirePodAtEnd]
+[-Documentation::RequirePodSections]
+
+[-ErrorHandling::RequireCarping]
+
+[-InputOutput::ProhibitBacktickOperators]
+[-InputOutput::ProhibitInteractiveTest]
+[-InputOutput::RequireCheckedSyscalls]
+functions = :builtins
+exclude_functions = print
+
+[-Miscellanea::RequireRcsKeywords]
+
+[-Modules::RequireVersionVar]
+
+[-RegularExpressions::ProhibitEscapedMetacharacters]
+[-RegularExpressions::RequireDotMatchAnything]
+[-RegularExpressions::RequireExtendedFormatting]
+[-RegularExpressions::RequireLineBoundaryMatching]
+
+[-ValuesAndExpressions::ProhibitConstantPragma]
+[-ValuesAndExpressions::ProhibitEmptyQuotes]
+[-ValuesAndExpressions::ProhibitMagicNumbers]
+
+[-Variables::ProhibitPunctuationVars]
Copied: branches/html_cleanup/tools/dev/perlcritic.conf (from r48747, trunk/tools/dev/perlcritic.conf)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/dev/perlcritic.conf Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/dev/perlcritic.conf)
@@ -0,0 +1,75 @@
+verbose = 3
+
+# not all the profiles listed here are installed by default, even if you have
+# Perl::Critic. Shhhh.
+profile-strictness = quiet
+
+[BuiltinFunctions::ProhibitStringySplit]
+add_themes = parrot
+
+[CodeLayout::ProhibitDuplicateCoda]
+add_themes = parrot
+
+[CodeLayout::ProhibitHardTabs]
+allow_leading_tabs = 0
+add_themes = parrot
+
+[CodeLayout::ProhibitTrailingWhitespace]
+add_themes = parrot
+
+[CodeLayout::RequireTidyCode]
+perltidyrc = tools/dev/perltidy.conf
+add_themes = extra
+
+[CodeLayout::UseParrotCoda]
+add_themes = parrot
+
+[InputOutput::ProhibitBarewordFileHandles]
+add_themes = parrot
+
+[InputOutput::ProhibitTwoArgOpen]
+add_themes = parrot
+
+[NamingConventions::ProhibitAmbiguousNames]
+# remove abstract from the list of forbidden names
+forbid = bases close contract last left no record right second set
+add_themes = extra
+
+[Subroutines::ProhibitBuiltinHomonyms]
+add_themes = extra
+
+[Subroutines::ProhibitExplicitReturnUndef]
+add_themes = parrot
+
+[Subroutines::ProhibitSubroutinePrototypes]
+add_themes = parrot
+
+[Subroutines::RequireFinalReturn]
+add_themes = extra
+
+[TestingAndDebugging::MisplacedShebang]
+add_themes = parrot
+
+[TestingAndDebugging::ProhibitShebangWarningsArg]
+add_themes = parrot
+
+[TestingAndDebugging::RequirePortableShebang]
+add_themes = parrot
+
+[TestingAndDebugging::RequireUseStrict]
+add_themes = parrot
+
+[TestingAndDebugging::RequireUseWarnings]
+add_themes = parrot
+
+[ValuesAndExpressions::ProhibitInterpolationOfLiterals]
+add_themes = extra
+
+[Variables::ProhibitConditionalDeclarations]
+add_themes = parrot
+
+[Bangs::ProhibitFlagComments]
+add_themes = extra
+
+[Bangs::ProhibitRefProtoOrProto]
+add_themes = extra
Copied: branches/html_cleanup/tools/dev/perltidy.conf (from r48747, trunk/tools/dev/perltidy.conf)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/dev/perltidy.conf Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/dev/perltidy.conf)
@@ -0,0 +1,15 @@
+# A declarative version of PDD07 for perl.
+
+# Must apply...
+
+-l=100 # Source line width is limited to 100 characters.
+-i=4 # must be indented four columns (no tabs)
+-ola # Labels (including case labels) must be outdented two columns
+-ci=4 # Long lines, when split, must use at least one extra level of indentation on the continued line.
+-ce # Cuddled elses are forbidden: i.e. avoid } else { .
+
+# Nice to haves...
+
+# Freeze new lines; some really short lines look good the way they
+# are, this should stop perltidy from merging them together
+-fnl
Copied: branches/html_cleanup/tools/dev/update_copyright.pl (from r48747, trunk/tools/dev/update_copyright.pl)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/dev/update_copyright.pl Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/dev/update_copyright.pl)
@@ -0,0 +1,63 @@
+#! perl
+# $Id$
+
+# Copyright (C) 2008, Parrot Foundation.
+
+use strict;
+use warnings;
+use Fatal qw( open close );
+
+=head1 NAME
+
+F<tools/dev/update_copyright.pl>
+
+=head1 DESCRIPTION
+
+Given a list of files as command line arguments, update the copyright
+notice to go from the earliest year noted to the current year.
+
+Edits the files in place. You should update the copyright on a modified
+file before you commit it back to the repository.
+
+=cut
+
+use lib 'lib';
+use Parrot::Test;
+
+# Accept a little fuzz in the original copyright notice..
+my $copyright_re = qr/
+ Copyright \s+ \(C\) \s+
+ (\d\d\d\d)\s*(?:-\s*\d\d\d\d)? \s* ,? \s*
+ The \s+ Perl \s+ Foundation\.?
+/xi;
+
+my $year = (localtime())[5]+1900;
+
+# loop over all the files specified on the command line
+foreach my $file (@ARGV) {
+ my $contents = Parrot::Test::slurp_file( $file );
+ if ( $contents =~ $copyright_re) {
+ my $old_year = $1;
+ if ($old_year eq $year) {
+ warn "$file already up to date.\n";
+ next;
+ }
+ else {
+ $contents =~ s/$copyright_re/Copyright (C) $old_year-$year, Parrot Foundation./;
+ open my $ofh, '>', $file;
+ print {$ofh} $contents;
+ close $ofh;
+ }
+ }
+ else {
+ warn "$file doesn't have a valid copyright line.\n";
+ }
+}
+
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Copied: branches/html_cleanup/tools/release/README (from r48747, trunk/tools/release/README)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/release/README Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/release/README)
@@ -0,0 +1,5 @@
+# $Id$
+README for tools/release/
+
+This directory is intended to hold programs, templates and configuration files
+useful during the release process.
Copied: branches/html_cleanup/tools/release/crow.pir (from r48747, trunk/tools/release/crow.pir)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/release/crow.pir Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/release/crow.pir)
@@ -0,0 +1,107 @@
+#! ./parrot
+# Copyright (C) 2007-2008, Parrot Foundation.
+# $Id$
+
+=head1 TITLE
+
+crow.pir -- Make noise about the new Parrot release
+
+=head1 DESCRIPTION
+
+This utility is used to help Release Managers format announcement messages.
+It uses a *very* simple and fast templating system, described in the related
+module, L<runtime/parrot/library/Crow.pir>.
+
+=head1 SYNOPSIS
+
+ # see
+ % parrot tools/release/crow.pir --help
+
+=cut
+
+
+.sub 'main' :main
+ .param pmc args
+
+ load_bytecode 'Crow.pbc'
+
+ .local pmc exports, curr_namespace, test_namespace
+ curr_namespace = get_namespace
+ test_namespace = get_namespace ['Crow']
+ exports = split ' ', 'get_news get_args process'
+ test_namespace.'export_to'(curr_namespace, exports)
+
+ .local pmc opts
+ opts = get_args(args)
+
+ unless null opts goto got_opts
+ opts = new 'Hash'
+ got_opts:
+
+ .local pmc templates
+ templates = 'get_json'('tools/release/templates.json')
+
+ .local string template, type
+ type = opts['type']
+ if type != '' goto got_type
+ type = 'text'
+
+got_type:
+ template = 'get_template'(templates, type)
+
+ .local pmc data
+ data = 'get_json'('tools/release/release.json')
+
+ .local string version
+ version = data['release.version']
+
+ $S0 = concat type, '.news'
+ $I0 = templates[$S0]
+ if $I0 goto get_news
+ data['NEWS'] = ''
+ goto process
+ get_news:
+ $S0 = 'get_news'(version)
+ data['NEWS'] = $S0
+
+
+ process:
+ .local string result
+ result = process(template, data)
+ say result
+.end
+
+
+.sub 'get_json'
+ .param string filename
+
+ load_bytecode 'Config/JSON.pbc'
+
+ .local pmc exports, curr_namespace, test_namespace
+ curr_namespace = get_namespace
+ test_namespace = get_namespace [ 'Config';'JSON' ]
+ exports = split ' ', 'ReadConfig'
+ test_namespace.'export_to'(curr_namespace, exports)
+
+ .local pmc result
+ result = ReadConfig(filename)
+
+ .return (result)
+.end
+
+
+.sub 'get_template'
+ .param pmc templates
+ .param string type
+
+ $S0 = concat type, '.text'
+ $S1 = templates[$S0]
+ .return ($S1)
+.end
+
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Copied: branches/html_cleanup/tools/release/gen_release_info.pl (from r48747, trunk/tools/release/gen_release_info.pl)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/release/gen_release_info.pl Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/release/gen_release_info.pl)
@@ -0,0 +1,63 @@
+#! perl
+# Copyright (C) 2008, Parrot Foundation.
+# $Id$
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+tools/release/gen_release_info.pl - generate release info for graphs and charts
+
+=head1 DESCRIPTION
+
+This utility generates release information from subversion in csv format,
+suitable for graphs, charts, and reports.
+
+=cut
+
+
+my $repo_url = 'https://svn.parrot.org/parrot/tags';
+
+## create a release information data structure
+my $r = {
+ map { $_->{number} => $_ }
+ map { m{^(RELEASE_)(.*)/}
+ ? {
+ tag => "$1$2",
+ number => sub{$a = shift; $a =~ y/_/./; $a }->($2),
+ }
+ : ()
+ }
+ qx { svn ls $repo_url }
+};
+
+## gather interesting release-related information from the tag
+map {
+ ## ask subversion for info about the tag
+ my $readme = $repo_url . '/' . $r->{$_}{tag};
+ warn "retrieving info on $readme\n";
+ my $info = qx{ LANG=C svn info $readme };
+
+ ## pull the interesting items
+ $info =~ m{Author: (\S+)} and $r->{$_}{author} = $1;
+ $info =~ m{Rev: (\S+)} and $r->{$_}{revision} = $1;
+ $info =~ m{Date: (\S+)} and $r->{$_}{date} = $1;
+} keys %{ $r };
+
+
+## output info in csv format
+print
+ map { "$_\n" }
+ map { my $n = $_; join ',' =>
+ map { $r->{$n}{$_} || '' }
+ qw{ tag number author revision date }
+ }
+ sort keys %$r;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4:
Copied: branches/html_cleanup/tools/release/inc_ver.pir (from r48747, trunk/tools/release/inc_ver.pir)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/release/inc_ver.pir Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/release/inc_ver.pir)
@@ -0,0 +1,48 @@
+#!/usr/bin/env parrot
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+.sub 'main' :main
+ .local string version_file_name
+ version_file_name = 'VERSION'
+
+ # read the version
+ $P0 = new 'FileHandle'
+ $P0.'open'( version_file_name, 'r' )
+ $S0 = $P0.'readline'()
+ $P0.'close'()
+
+ print 'version: '
+ print $S0
+
+ # split the version
+ $P1 = split '.', $S0
+
+ # increment version
+ $I0 = $P1[1]
+ inc $I0
+ if $I0 != 12 goto NOT_NILL
+ $I0 = $P1[0]
+ inc $I0
+ $P1[0] = $I0
+ $I0 = 0
+NOT_NILL:
+ $P1[1] = $I0
+
+ # join the incremented version
+ $S0 = join '.', $P1
+
+ print 'new version: '
+ print $S0
+
+ # write the new version to the version_file
+ $P0.'open'( version_file_name, 'w' )
+ $P0.'print'( $S0 )
+ $P0.'close'()
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Copied: branches/html_cleanup/tools/release/release.json (from r48747, trunk/tools/release/release.json)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/release/release.json Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/release/release.json)
@@ -0,0 +1,21 @@
+{
+ "release.version" : "2.7.0",
+ "release.name" : "Australian King",
+ "release.day" : "Tuesday",
+ "release.date" : "17 August 2010",
+ "release.nextdate" : "21 September 2010",
+
+ "web.root" : "http://parrot.org/",
+ "web.source" : "download",
+ "web.openpatches" : "openpatches.html",
+ "web.repository" : "https://svn.parrot.org/parrot/trunk/",
+
+ "bugday.day" : "Saturday",
+ "bugday.date" : "18 September 2010",
+
+ "wiki.root" : "https://trac.parrot.org/parrot/wiki/",
+ "wiki.bugday" : "bug_day_2010_09_18",
+
+ "ftp.path" : "ftp://ftp.parrot.org/pub/parrot/releases/devel/2.7.0/",
+ "subversion.root" : "http://subversion.apache.org/"
+}
Copied: branches/html_cleanup/tools/release/templates.json (from r48747, trunk/tools/release/templates.json)
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/html_cleanup/tools/release/templates.json Wed Sep 1 06:33:06 2010 (r48748, copy of r48747, trunk/tools/release/templates.json)
@@ -0,0 +1,83 @@
+{
+ "text.news" : true,
+ "text.text" : "
+
+On behalf of the Parrot team, I'm proud to announce Parrot @release.version@
+\"@release.name at .\" Parrot (@web.root@) is a virtual machine aimed
+at running all dynamic languages.
+
+Parrot @release.version@ is available on Parrot's FTP site, or follow the
+download instructions at @web.root@@web.source at . For those who would like to
+develop on Parrot, or help develop Parrot itself, we recommend using Subversion
+on the source code repository to get the latest and best Parrot code.
+
+Parrot @release.version@ News:
+ at NEWS@
+
+Many thanks to all our contributors for making this possible, and our sponsors
+for supporting this project. Our next scheduled release is @release.nextdate at .
+
+Enjoy!
+
+",
+
+ "html.news" : true,
+ "html.text" : "
+<p>On behalf of the Parrot team, I'm proud to announce Parrot @release.version@
+"@release.name at ." <a href=\"@web.root@\">Parrot</a>
+is a virtual machine aimed at running all dynamic languages.</p>
+
+<p>Parrot @release.version@ is available on <a href=\"@ftp.path@\">Parrot's FTP
+site</a>, or <a href=\"@web.root@@web.source@\">follow the download
+instructions</a>. For those who would like to develop on Parrot, or help
+develop Parrot itself, we recommend using <a
+href=\"@subversion.root@\">Subversion</a> on <a href=\"@web.repository@\">our
+source code repository</a> to get the latest and best Parrot code.</p>
+
+<p>Parrot @release.version@ News:<br/>
+<pre>@NEWS@</pre></p>
+
+<p>Thanks to all our contributors for making this possible, and our sponsors
+for supporting this project. Our next release is @release.nextdate at .</p>
+
+<p>Enjoy!</p>
+",
+
+ "bugday.news" : false,
+ "bugday.text" : "
+Bug Day
+
+On @bugday.day@, @bugday.date@, please join us on IRC in #parrot
+(irc.parrot.org) to work on closing out as many Trac tickets
+(https://trac.parrot.org) tickets as possible in the parrot queue. This will
+help us get ready for the next release of parrot: @release.version@, scheduled
+for @release.day@, @release.date at . You'll find C, parrot assembly, perl,
+documentation, and plenty of tasks to go around. Core developers will be
+available most of the day (starting at around 10am GMT) to answer questions.
+
+No experience with parrot necessary.
+
+--From: @wiki.root@@wiki.bugday at --
+
+Check the list at:
+
+https://trac.parrot.org/parrot/report/3
+
+Which contains all the tickets I'd like to see resolved in @version at . To
+see all the open tickets, use:
+
+https://trac.parrot.org/parrot/report
+
+If you've got something you're working on that you think you'll be
+getting done before the release, please
+- add a ticket for it (if necessary);
+- set its milestone to this release.
+
+Thanks in advance for your patches and commits. ^_^
+
+... Speaking of patches, we should also get through as many of these
+(accept or reject) as possible.
+
+ at web.root@@web.openpatches@
+"
+}
More information about the parrot-commits
mailing list