Author: Whiteknight
Date: Fri Jul 18 14:19:04 2008
New Revision: 29595
Modified:
branches/gsoc_pdd09/NEWS
branches/gsoc_pdd09/compilers/imcc/imcc.y
branches/gsoc_pdd09/config/gen/makefiles/root.in
branches/gsoc_pdd09/languages/perl6/src/builtins/guts.pir
branches/gsoc_pdd09/languages/perl6/src/classes/Any.pir
branches/gsoc_pdd09/languages/perl6/src/classes/Object.pir
branches/gsoc_pdd09/languages/perl6/src/parser/actions.pm
branches/gsoc_pdd09/languages/perl6/src/parser/grammar.pg
branches/gsoc_pdd09/languages/perl6/t/spectest_regression.data
branches/gsoc_pdd09/lib/Parrot/Harness/DefaultTests.pm
branches/gsoc_pdd09/lib/Parrot/Harness/Smoke.pm
branches/gsoc_pdd09/lib/Parrot/Ops2pm/Utils.pm
branches/gsoc_pdd09/runtime/parrot/library/P6object.pir
branches/gsoc_pdd09/src/pmc/default.pmc
branches/gsoc_pdd09/t/harness
branches/gsoc_pdd09/t/library/p6object.t
Log:
[gsoc_pdd09] update to trunk r29594
Modified: branches/gsoc_pdd09/NEWS
==============================================================================
--- branches/gsoc_pdd09/NEWS (original)
+++ branches/gsoc_pdd09/NEWS Fri Jul 18 14:19:04 2008
@@ -1,6 +1,8 @@
# $Id$
New in August 2008 release
+- Tools
+ + parrot_debugger renamed from pdb
- Implementation
+ removed opcode getfd
Modified: branches/gsoc_pdd09/compilers/imcc/imcc.y
==============================================================================
--- branches/gsoc_pdd09/compilers/imcc/imcc.y (original)
+++ branches/gsoc_pdd09/compilers/imcc/imcc.y Fri Jul 18 14:19:04 2008
@@ -996,8 +996,7 @@
SUB_INSTANCE_OF '(' STRINGC ')'
{
$$ = 0;
- IMCC_INFO(interp)->cur_unit->instance_of = mk_const(interp, $3,
'S');
- mem_sys_free($3);
+ IMCC_INFO(interp)->cur_unit->instance_of = $3;
}
;
@@ -1005,7 +1004,8 @@
SUB_LEXID '(' STRINGC ')'
{
$$ = 0;
- IMCC_INFO(interp)->cur_unit->lexid = $3;
+ IMCC_INFO(interp)->cur_unit->lexid = mk_const(interp, $3, 'S');
+ mem_sys_free($3);
}
;
Modified: branches/gsoc_pdd09/config/gen/makefiles/root.in
==============================================================================
--- branches/gsoc_pdd09/config/gen/makefiles/root.in (original)
+++ branches/gsoc_pdd09/config/gen/makefiles/root.in Fri Jul 18 14:19:04 2008
@@ -693,6 +693,7 @@
@echo " smokeexec: Same as smoke, but generate first
executables"
@echo " with the exec runcore"
@echo " smoke-clean: clean up smoke.html"
+ @echo " smolder_test: Run the test suite and send report to the
smolder server"
@echo ""
@echo "Benchmarks:"
@echo " mopsbench: Million operations"
Modified: branches/gsoc_pdd09/languages/perl6/src/builtins/guts.pir
==============================================================================
--- branches/gsoc_pdd09/languages/perl6/src/builtins/guts.pir (original)
+++ branches/gsoc_pdd09/languages/perl6/src/builtins/guts.pir Fri Jul 18
14:19:04 2008
@@ -217,11 +217,17 @@
=cut
.sub '!keyword_class'
- .param string name
+ .param string name :optional
+ .param int have_name :opt_flag
.local pmc class, resolve_list, methods, iter
# Create class.
+ if have_name goto named
+ class = new 'Class'
+ goto created
+ named:
class = newclass name
+ created:
# Set resolve list to include all methods of the class.
methods = inspect class, 'methods'
Modified: branches/gsoc_pdd09/languages/perl6/src/classes/Any.pir
==============================================================================
--- branches/gsoc_pdd09/languages/perl6/src/classes/Any.pir (original)
+++ branches/gsoc_pdd09/languages/perl6/src/classes/Any.pir Fri Jul 18
14:19:04 2008
@@ -30,7 +30,7 @@
.sub 'can' :method
.param pmc x
$P0 = self.'HOW'()
- .return $P0.'can'(x)
+ .return $P0.'can'(self, x)
.end
=item isa($x)
@@ -40,7 +40,7 @@
.sub 'isa' :method
.param pmc x
$P0 = self.'HOW'()
- .return $P0.'isa'(x)
+ .return $P0.'isa'(self, x)
.end
=back
Modified: branches/gsoc_pdd09/languages/perl6/src/classes/Object.pir
==============================================================================
--- branches/gsoc_pdd09/languages/perl6/src/classes/Object.pir (original)
+++ branches/gsoc_pdd09/languages/perl6/src/classes/Object.pir Fri Jul 18
14:19:04 2008
@@ -322,6 +322,17 @@
.return $P0(self)
.end
+=item WHERE
+
+Gets the memory address of the object.
+
+=cut
+
+.sub 'WHERE' :method
+ $I0 = get_addr self
+ .return ($I0)
+.end
+
=back
=head2 Private methods
@@ -437,6 +448,100 @@
.end
+.sub '!.^' :method
+ .param string method_name
+ .param pmc pos_args :slurpy
+ .param pmc named_args :slurpy :named
+
+ # Get the HOW or the object and do the call on that.
+ .local pmc how
+ how = self.'HOW'()
+ .return how.method_name(self, pos_args :flat, named_args :flat :named)
+.end
+
+
+.namespace ['P6protoobject']
+
+=back
+
+=head2 Methods on P6protoobject
+
+=over
+
+=item WHENCE()
+
+Returns the protoobject's autovivification closure.
+
+=cut
+
+.sub 'WHENCE' :method
+ .local pmc props, whence
+ props = getattribute self, '%!properties'
+ if null props goto ret_undef
+ whence = props['WHENCE']
+ if null whence goto ret_undef
+ .return (whence)
+ ret_undef:
+ whence = new 'Undef'
+ .return (whence)
+.end
+
+
+=item get_pmc_keyed(key) (vtable method)
+
+Returns a proto-object with an autovivification closure attached to it.
+
+=cut
+
+.sub get_pmc_keyed :vtable :method
+ .param pmc what
+
+ # We'll build auto-vivification hash of values.
+ .local pmc WHENCE, key, val
+ WHENCE = new 'Hash'
+
+ # What is it?
+ $S0 = what.'WHAT'()
+ if $S0 == 'Pair' goto from_pair
+ if $S0 == 'List' goto from_list
+ 'die'("Auto-vivification closure did not contain a Pair")
+
+ from_pair:
+ # Just a pair.
+ key = what.'key'()
+ val = what.'value'()
+ WHENCE[key] = val
+ goto done_whence
+
+ from_list:
+ # List.
+ .local pmc list_iter, cur_pair
+ list_iter = new 'Iterator', what
+ list_iter_loop:
+ unless list_iter goto done_whence
+ cur_pair = shift list_iter
+ key = cur_pair.'key'()
+ val = cur_pair.'value'()
+ WHENCE[key] = val
+ goto list_iter_loop
+ done_whence:
+
+ # Now create a clone of the protoobject.
+ .local pmc protoclass, res, props, tmp
+ protoclass = class self
+ res = new protoclass
+
+ # Attach the WHENCE property.
+ props = getattribute self, '%!properties'
+ unless null props goto have_props
+ props = new 'Hash'
+ have_props:
+ props['WHENCE'] = WHENCE
+ setattribute res, '%!properties', props
+
+ .return (res)
+.end
+
=back
=cut
Modified: branches/gsoc_pdd09/languages/perl6/src/parser/actions.pm
==============================================================================
--- branches/gsoc_pdd09/languages/perl6/src/parser/actions.pm (original)
+++ branches/gsoc_pdd09/languages/perl6/src/parser/actions.pm Fri Jul 18
14:19:04 2008
@@ -423,6 +423,11 @@
$pirflags := $pirflags ~ ' :multi(';
my $arity := [EMAIL PROTECTED];
my $count := 0;
+ if $<routine_declarator><sym> eq 'method' {
+ # For methods, need to have a slot in the multi list for the
+ # invocant. XXX could be a type constraint in the sig on self.
+ $pirflags := $pirflags ~ '_, ';
+ }
while $count != $arity {
# How many types do we have?
my $checks := @check_list[$count];
@@ -483,6 +488,7 @@
if $<method_def><multisig> {
set_block_sig($past, $( $<method_def><multisig>[0]<signature> ));
}
+ $past := add_method_to_class($past);
}
$past.node($/);
if (+@($past[1])) {
@@ -1233,7 +1239,7 @@
}
elsif $key eq '.*' {
$past := $( $<methodop> );
- if $/[0] eq '.?' || $/[0] eq '.+' || $/[0] eq '.*' {
+ if $/[0] eq '.?' || $/[0] eq '.+' || $/[0] eq '.*' || $/[0] eq '.^' {
my $name := $past.name();
unless $name {
$/.panic("Cannot use " ~ $/[0] ~ " when method is a code ref");
@@ -1376,7 +1382,7 @@
:scope('lexical')
),
PAST::Var.new(
- :name(~$_<trait_auxiliary><role_name><name>),
+ :name(~$_<trait_auxiliary><name>),
:scope('package')
)
)
@@ -1451,23 +1457,32 @@
if $key eq 'open' {
# Start of package definition. Handle class and grammar specially.
if $?PACKAGE =:= $?CLASS {
- # Start of class definition; create class object to work with.
- $?CLASS.push(
+ # Start of class definition; make PAST to create class object.
+ my $class_def := PAST::Op.new(
+ :pasttype('bind'),
+ PAST::Var.new(
+ :name('$def'),
+ :scope('lexical')
+ ),
PAST::Op.new(
- :pasttype('bind'),
- PAST::Var.new(
- :name('$def'),
- :scope('lexical')
- ),
- PAST::Op.new(
- :pasttype('call'),
- :name('!keyword_class'),
- PAST::Val.new( :value(~$<name>) )
- )
+ :pasttype('call'),
+ :name('!keyword_class')
)
);
+
+ # Add a name, if we have one.
+ if $<name> {
+ $class_def[1].push( PAST::Val.new( :value(~$<name>[0]) ) );
+ }
+
+ $?CLASS.push($class_def);
}
elsif $?PACKAGE =:= $?GRAMMAR {
+ # Anonymous grammars not supported.
+ unless $<name> {
+ $/.panic('Anonymous grammars not supported');
+ }
+
# Start of grammar definition. Create grammar class object.
$?GRAMMAR.push(
PAST::Op.new(
@@ -1479,20 +1494,30 @@
PAST::Op.new(
:pasttype('call'),
:name('!keyword_grammar'),
- PAST::Val.new( :value(~$<name>) )
+ PAST::Val.new( :value(~$<name>[0]) )
)
)
);
}
+ else {
+ # Anonymous modules not supported.
+ unless $<name> {
+ $/.panic('Anonymous modules not supported');
+ }
+ }
- # Also store the current namespace.
- $?NS := $<name><ident>;
+ # Also store the current namespace, if we're not anonymous.
+ if $<name> {
+ $?NS := $<name>[0]<ident>;
+ }
}
else {
# Declare the namespace and that the result block holds things that we
# do "on load".
my $past := $( $<package_block> );
- $past.namespace($<name><ident>);
+ if $<name> {
+ $past.namespace($<name>[0]<ident>);
+ }
$past.blocktype('declaration');
$past.pirflags(':init :load');
@@ -1521,15 +1546,29 @@
)
);
+ # If this is an anonymous class, the block doesn't want to be a
+ # :init :load, and it's going to contain the class definition, so
+ # we need to declare the lexical $def.
+ unless $<name> {
+ $past.pirflags('');
+ $past.blocktype('immediate');
+ $past.push(PAST::Var.new(
+ :name('$def'),
+ :scope('lexical'),
+ :isdecl(1)
+ ));
+ }
+
# Attatch any class initialization code to the init code;
# note that we skip blocks, which are method accessors that
# we want to put under this block so they get the correct
- # namespace.
+ # namespace. If it's an anonymous class, everything goes into
+ # this block.
unless defined( $?INIT ) {
$?INIT := PAST::Block.new();
}
for @( $?CLASS ) {
- if $_.WHAT() eq 'Block' {
+ if $_.WHAT() eq 'Block' || !$<name> {
$past.push( $_ );
}
else {
@@ -1591,19 +1630,19 @@
PAST::Op.new(
:pasttype('call'),
:name('!keyword_role'),
- PAST::Val.new( :value(~$<role_name>) )
+ PAST::Val.new( :value(~$<name>) )
)
)
);
# Also store the current namespace.
- $?NS := $<role_name><name><ident>;
+ $?NS := $<name><ident>;
}
else {
# Declare the namespace and that the result block holds things that we
# do "on load".
my $past := $( $<package_block> );
- $past.namespace($<role_name><name><ident>);
+ $past.namespace($<name><ident>);
$past.blocktype('declaration');
$past.pirflags(':init :load');
@@ -1820,7 +1859,7 @@
if $variable_twigil eq '.' {
# We have a . twigil, so we need to generate an accessor.
my $accessor := make_accessor($/, ~$variable_name, $name, $rw);
- $class_def.unshift($accessor);
+ $class_def.push(add_method_to_class($accessor));
}
elsif $variable_twigil eq '!' {
# Don't need to do anything.
@@ -2411,7 +2450,7 @@
:node($/)
);
my $rhs := $( $/[1] );
- if $rhs.HOW().isa(PAST::Op) && $rhs.pasttype() eq 'call' {
+ if $rhs.HOW().isa($rhs, PAST::Op) && $rhs.pasttype() eq 'call' {
# Make sure we only have one initialization value.
if +@($rhs) > 2 {
$/.panic("Role initialization can only supply a value for one
attribute");
@@ -2715,11 +2754,13 @@
if $expr.WHAT() eq 'Val' && $expr.returns() eq 'Perl6Str' {
# Just a single string mapping.
my $name := ~$expr.value();
- $past.push(make_handles_method($/, $name, $name, $attr_name));
+ my $method := make_handles_method($/, $name, $name, $attr_name);
+ $past.push(add_method_to_class($method));
}
elsif $expr.WHAT() eq 'Op' && $expr.returns() eq 'Pair' {
# Single pair.
- $past.push(make_handles_method_from_pair($/, $expr, $attr_name));
+ my $method := make_handles_method_from_pair($/, $expr, $attr_name);
+ $past.push(add_method_to_class($method));
}
elsif $expr.WHAT() eq 'Op' && $expr.pasttype() eq 'call' &&
$expr.name() eq 'list' {
@@ -2728,11 +2769,13 @@
if $_.WHAT() eq 'Val' && $_.returns() eq 'Perl6Str' {
# String value.
my $name := ~$_.value();
- $past.push(make_handles_method($/, $name, $name, $attr_name));
+ my $method := make_handles_method($/, $name, $name,
$attr_name);
+ $past.push(add_method_to_class($method));
}
elsif $_.WHAT() eq 'Op' && $_.returns() eq 'Pair' {
# Pair.
- $past.push(make_handles_method_from_pair($/, $_, $attr_name));
+ my $method := make_handles_method_from_pair($/, $_,
$attr_name);
+ $past.push(add_method_to_class($method));
}
else {
$/.panic(
@@ -2747,11 +2790,13 @@
if $_.WHAT() eq 'Val' && $_.returns() eq 'Perl6Str' {
# String value.
my $name := ~$_.value();
- $past.push(make_handles_method($/, $name, $name, $attr_name));
+ my $method := make_handles_method($/, $name, $name,
$attr_name);
+ $past.push(add_method_to_class($method));
}
elsif $_.WHAT() eq 'Op' && $_.returns() eq 'Pair' {
# Pair.
- $past.push(make_handles_method_from_pair($/, $_, $attr_name));
+ my $method := make_handles_method_from_pair($/, $_,
$attr_name);
+ $past.push(add_method_to_class($method));
}
else {
$/.panic(
@@ -3006,6 +3051,44 @@
$accessor
}
+
+# Adds the given method to the current class. This just returns the method that
+# is passed to it if the current class is named; in the case that it is
anonymous
+# we need instead to emit an add_method call and remove the methods name so it
+# doesn't pollute the namespace.
+sub add_method_to_class($method) {
+ our $?CLASS;
+ our $?PACKAGE;
+ if $?CLASS =:= $?PACKAGE && +@($?CLASS[0][1]) == 0 {
+ # Create new PAST::Block - can't work out how to unset the name of an
+ # existing one.
+ my $new_method := PAST::Block.new(
+ :blocktype($method.blocktype()),
+ :pirflags($method.pirflags())
+ );
+ for @($method) {
+ $new_method.push($_);
+ }
+
+ # Put call to add method into the class definition.
+ $?CLASS.push(PAST::Op.new(
+ :pasttype('callmethod'),
+ :name('add_method'),
+ PAST::Var.new(
+ :name('$def'),
+ :scope('lexical')
+ ),
+ PAST::Val.new( :value($method.name()) ),
+ $new_method
+ ));
+
+ $new_method
+ }
+ else {
+ $method
+ }
+}
+
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
Modified: branches/gsoc_pdd09/languages/perl6/src/parser/grammar.pg
==============================================================================
--- branches/gsoc_pdd09/languages/perl6/src/parser/grammar.pg (original)
+++ branches/gsoc_pdd09/languages/perl6/src/parser/grammar.pg Fri Jul 18
14:19:04 2008
@@ -353,7 +353,7 @@
rule trait_auxiliary {
| $<sym>=[is] <name><postcircumfix>?
- | $<sym>=[does] <role_name>
+ | $<sym>=[does] <name>['['<EXPR>']']?
| $<sym>=[will] <ident> <block>
}
@@ -362,8 +362,6 @@
| $<sym>=[handles] <EXPR>
}
-token role_name { <name> [ <?before '['> <postcircumfix> ]? }
-
token capterm {
'\\(' <capture> ')'
{*}
@@ -549,7 +547,7 @@
## XXX: cheat until we get term:pi, term:rand, term:undef, etc.
token named_0ary {
- [pi|rand|undef] >>
+ [pi|rand|undef|nothing] >>
}
rule package_declarator {
@@ -563,13 +561,13 @@
rule package_def {
- <name> <trait>* {*} #= open
+ <name>? <trait>* {*} #= open
<package_block> {*} #= close
}
rule role_def {
- <role_name> <trait>* {*} #= open
+ <name>['['<signature>']']? <trait>* {*} #= open
<package_block> {*} #= close
}
Modified: branches/gsoc_pdd09/languages/perl6/t/spectest_regression.data
==============================================================================
--- branches/gsoc_pdd09/languages/perl6/t/spectest_regression.data
(original)
+++ branches/gsoc_pdd09/languages/perl6/t/spectest_regression.data Fri Jul
18 14:19:04 2008
@@ -37,6 +37,7 @@
S04-declarations/multiple.t
S04-declarations/my.t
S04-declarations/implicit-parameter.t # pure
+S04-statements/do.t
S04-statements/for.t
S04-statements/no-implicit-block.t
S04-statements/repeat.t
@@ -49,6 +50,7 @@
S06-signature/named-placeholders.t # pure
S06-signature/positional-placeholders.t # pure
S06-signature/slurpy-placeholders.t # pure
+S12-class/annonymous.t # pure
S12-class/attributes.t # pure
S12-class/instantiate.t # pure
S12-class/parent_attributes.t # pure
Modified: branches/gsoc_pdd09/lib/Parrot/Harness/DefaultTests.pm
==============================================================================
--- branches/gsoc_pdd09/lib/Parrot/Harness/DefaultTests.pm (original)
+++ branches/gsoc_pdd09/lib/Parrot/Harness/DefaultTests.pm Fri Jul 18
14:19:04 2008
@@ -83,33 +83,11 @@
t/distro/manifest.t
);
[EMAIL PROTECTED] = (
- 't/distro/file_metadata.t',
- map { "t/codingstd/$_" } qw(
- c_code_coda.t
- c_cppcomments.t
- c_header_guards.t
- c_indent.t
- c_macro_args.t
- c_operator.t
- c_parens.t
- c_returns.t
- c_struct.t
- check_isxxx.t
- check_toxxx.t
- copyright.t
- cuddled_else.t
- filenames.t
- gmt_utc.t
- linelength.t
- pccmethod_deps.t
- perlcritic.t
- pir_code_coda.t
- svn_id.t
- tabs.t
- trailing_space.t
- )
-);
[EMAIL PROTECTED] = ( 't/distro/file_metadata.t' );
+# Add in all t/codingstd except for a few skips.
+push @developing_tests,
+ grep { ! m/(c_function_docs|fixme|pdd_format|pod_todo)\.t$/ }
+ glob 't/codingstd/*.t';
sub get_default_tests {
my ($core_tests_only, $runcore_tests_only) = @_;
Modified: branches/gsoc_pdd09/lib/Parrot/Harness/Smoke.pm
==============================================================================
--- branches/gsoc_pdd09/lib/Parrot/Harness/Smoke.pm (original)
+++ branches/gsoc_pdd09/lib/Parrot/Harness/Smoke.pm Fri Jul 18 14:19:04 2008
@@ -10,7 +10,7 @@
This package exports on request subroutines used by F<t/harness> to generate
smoke reports.
-Currently, only one such subroutine is supported:
+Following subroutines are supported:
generate_html_smoke_report (
tests => [EMAIL PROTECTED],
@@ -18,6 +18,10 @@
file => 'smoke.html',
);
+ my %env_data = collect_test_environment_data();
+
+ send_archive_to_smolder( %env_data );
+
=cut
package Parrot::Harness::Smoke;
@@ -30,6 +34,7 @@
use base qw( Exporter );
our @EXPORT_OK = qw(
generate_html_smoke_report
+ collect_test_environment_data
send_archive_to_smolder
);
@@ -41,41 +46,69 @@
);
sub send_archive_to_smolder {
+ my %test_env_data = @_;
eval { require LWP::UserAgent };
if( $@ ) {
die "\n" . ('-' x 55) . "\nCould not load LWP::UserAgent."
- . "\nPlease install it if you want to send TAP archives smolder.\n"
+ . "\nPlease install it if you want to send TAP archives Smolder.\n"
. ('-' x 55) . "[EMAIL PROTECTED]";
}
- # get the comments from svn
- my @lines = grep { $_ =~ /URL|Revision|LastChanged/ } `svn info`;
- push @lines, `$^X -v | grep -i 'this is perl'`;
- chomp @lines;
- my $comments = join("\n", @lines);
-
- my $url =
"$SMOLDER_CONFIG{server}/app/developer_projects/process_add_report/$SMOLDER_CONFIG{project_id}";
+ my $url = $SMOLDER_CONFIG{server}
+ . '/app/developer_projects/process_add_report/'
+ . $SMOLDER_CONFIG{project_id};
my $ua = LWP::UserAgent->new();
+
+ # create our tags based off the test environment information
+ my $tags = join(',',
+ (map { $test_env_data{$_} } qw(Architecture Compiler Platform
Version)),
+ 'Perl ' . $test_env_data{'Perl Version'});
my $response = $ua->post(
$url,
Content_Type => 'form-data',
Content => [
- architecture => $PConfig{cpuarch},
- platform => $PConfig{osname},
- comments => $comments,
username => $SMOLDER_CONFIG{username},
password => $SMOLDER_CONFIG{password},
+ tags => $tags,
report_file => ['parrot_test_run.tar.gz'],
]
);
- if ($response->code != 302) {
+ if ($response->code == 302) {
+ print "Test report successfully sent to Smolder at\n"
+ . $SMOLDER_CONFIG{server}
+ . '/app/public_projects/smoke_reports/'
+ . $SMOLDER_CONFIG{project_id} . "\n";
+ }
+ else {
die "Could not upload report to Smolder at $SMOLDER_CONFIG{server}"
. "\nHTTP CODE: " . $response->code . " ("
. $response->message . ")\n";
}
}
+sub collect_test_environment_data {
+ return (
+ 'Architecture' => $PConfig{cpuarch},
+ 'Compiler' => _get_compiler_version(),
+ 'DEVEL' => $PConfig{DEVEL},
+ 'Optimize' => ($PConfig{optimize} || 'none'),
+ 'Perl Version' => (sprintf('%vd', $^V) . " $PConfig{archname}"),
+ 'Platform' => $PConfig{osname},
+ 'SVN Revision' => $PConfig{revision},
+ 'Version' => $PConfig{VERSION},
+ );
+}
+
+# this can be expanded to more than just GCC
+sub _get_compiler_version {
+ my $compiler = $PConfig{cc};
+ if($compiler eq 'gcc') {
+ $compiler .= " $PConfig{gccversion}";
+ }
+ return $compiler;
+}
+
sub generate_html_smoke_report {
my $argsref = shift;
my $html_fn = $argsref->{file};
Modified: branches/gsoc_pdd09/lib/Parrot/Ops2pm/Utils.pm
==============================================================================
--- branches/gsoc_pdd09/lib/Parrot/Ops2pm/Utils.pm (original)
+++ branches/gsoc_pdd09/lib/Parrot/Ops2pm/Utils.pm Fri Jul 18 14:19:04 2008
@@ -481,7 +481,7 @@
=item * Return Value
-Returns true value upon successful completion.
+Returns true value upon successful completion.
=item * Comment
Modified: branches/gsoc_pdd09/runtime/parrot/library/P6object.pir
==============================================================================
--- branches/gsoc_pdd09/runtime/parrot/library/P6object.pir (original)
+++ branches/gsoc_pdd09/runtime/parrot/library/P6object.pir Fri Jul 18
14:19:04 2008
@@ -164,11 +164,12 @@
=cut
.sub 'isa' :method
+ .param pmc obj
.param pmc x
.local pmc parrotclass
parrotclass = self.'get_parrotclass'(x)
- $P0 = self.'WHAT'()
+ $P0 = obj.'WHAT'()
$I0 = isa $P0, parrotclass
.return ($I0)
.end
@@ -180,9 +181,9 @@
=cut
.sub 'can' :method
+ .param pmc obj
.param string x
- .local pmc parrotclass
- $P0 = self.'WHAT'()
+ $P0 = obj.'WHAT'()
$I0 = can $P0, x
.return ($I0)
.end
@@ -359,8 +360,10 @@
## save the protoobject
setattribute how, 'protoobject', protoobject
- ## store the long and short names in the protoobject
+ ## store the long and short names in the protoobject; skip if anonymous
.local pmc longname, shortname
+ $I0 = elements ns
+ if $I0 == 0 goto anonymous_class
$S0 = join '::', ns
longname = new 'String'
longname = $S0
@@ -371,6 +374,14 @@
## store the protoobject in appropriate namespace
$S0 = pop ns
set_hll_global ns, $S0, protoobject
+ goto have_how
+
+ ## anonymous classes have empty strings for shortname and longname
+ anonymous_class:
+ longname = new 'String'
+ shortname = new 'String'
+ setattribute how, 'longname', longname
+ setattribute how, 'shortname', shortname
have_how:
## map parrotclass to the metaobject
@@ -519,81 +530,6 @@
.end
-=item WHENCE()
-
-Returns the protoobject's autovivification closure.
-
-=cut
-
-.sub 'WHENCE' :method
- .local pmc props, whence
- props = getattribute self, '%!properties'
- if null props goto ret_undef
- whence = props['WHENCE']
- if null whence goto ret_undef
- .return (whence)
- ret_undef:
- whence = new 'Undef'
- .return (whence)
-.end
-
-
-=item get_pmc_keyed(key) (vtable method)
-
-Returns a proto-object with an autovivification closure attached to it.
-
-=cut
-
-.sub get_pmc_keyed :vtable :method
- .param pmc what
-
- # We'll build auto-vivification hash of values.
- .local pmc WHENCE, key, val
- WHENCE = new 'Hash'
-
- # What is it?
- $S0 = what.'WHAT'()
- if $S0 == 'Pair' goto from_pair
- if $S0 == 'List' goto from_list
- 'die'("Auto-vivification closure did not contain a Pair")
-
- from_pair:
- # Just a pair.
- key = what.'key'()
- val = what.'value'()
- WHENCE[key] = val
- goto done_whence
-
- from_list:
- # List.
- .local pmc list_iter, cur_pair
- list_iter = new 'Iterator', what
- list_iter_loop:
- unless list_iter goto done_whence
- cur_pair = shift list_iter
- key = cur_pair.'key'()
- val = cur_pair.'value'()
- WHENCE[key] = val
- goto list_iter_loop
- done_whence:
-
- # Now create a clone of the protoobject.
- .local pmc protoclass, res, props, tmp
- protoclass = class self
- res = new protoclass
-
- # Attach the WHENCE property.
- props = getattribute self, '%!properties'
- unless null props goto have_props
- props = new 'Hash'
- have_props:
- props['WHENCE'] = WHENCE
- setattribute res, '%!properties', props
-
- .return (res)
-.end
-
-
=item ACCEPTS(topic)
=cut
Modified: branches/gsoc_pdd09/src/pmc/default.pmc
==============================================================================
--- branches/gsoc_pdd09/src/pmc/default.pmc (original)
+++ branches/gsoc_pdd09/src/pmc/default.pmc Fri Jul 18 14:19:04 2008
@@ -30,7 +30,7 @@
/*
-=item C<static const char *caller(PARROT_INTERP, PMC *pmc)>
+=item C<static STRING *caller(PARROT_INTERP, PMC *pmc)>
Returns a C string for the name of C<*pmc>.
@@ -38,11 +38,11 @@
*/
-static const char *
+static STRING *
caller(PARROT_INTERP, PMC *pmc /*NULLOK*/)
{
return pmc && pmc->vtable && pmc->vtable->whoami ?
- VTABLE_name(interp, pmc)->strstart : "(null)";
+ VTABLE_name(interp, pmc) : CONST_STRING(interp, "(null)");
}
/*
@@ -61,7 +61,7 @@
cant_do_method(PARROT_INTERP, PMC *pmc /*NULLOK*/, const char *methname)
{
real_exception(interp, NULL, ILL_INHERIT,
- "%s() not implemented in class '%s'", methname,
+ "%s() not implemented in class '%Ss'", methname,
caller(interp, pmc));
}
@@ -296,7 +296,7 @@
SELF.init();
else
real_exception(interp, NULL, ILL_INHERIT,
- "init_pmc() not implemented in class '%s'",
+ "init_pmc() not implemented in class '%Ss'",
caller(interp, pmc));
}
Modified: branches/gsoc_pdd09/t/harness
==============================================================================
--- branches/gsoc_pdd09/t/harness (original)
+++ branches/gsoc_pdd09/t/harness Fri Jul 18 14:19:04 2008
@@ -24,6 +24,7 @@
use Parrot::Harness::Smoke qw(
generate_html_smoke_report
send_archive_to_smolder
+ collect_test_environment_data
);
local @ARGV = @ARGV;
@@ -80,30 +81,36 @@
. "\nPlease install it if you want to create TAP archives.\n"
. ('-' x 55) . "[EMAIL PROTECTED]";
}
+ # for extra_properties we need TAP::Harness::Archive >= .10
+ if ($TAP::Harness::Archive::VERSION < .10) {
+ die "\n" . ('-' x 55) . "\nWe need TAP::Harness::Archive >= .10."
+ . "\nPlease install it if you want to create TAP archives.\n"
+ . ('-' x 55) . "\n";
+ }
+
+ my %env_data = collect_test_environment_data();
$harness = TAP::Harness::Archive->new(
{
- verbosity => $ENV{HARNESS_VERBOSE},
- archive => 'parrot_test_run.tar.gz',
- merge => 1,
+ verbosity => $ENV{HARNESS_VERBOSE},
+ archive => 'parrot_test_run.tar.gz',
+ merge => 1,
+ extra_properties => \%env_data,
}
);
+ $harness->runtests(@tests);
+ send_archive_to_smolder(%env_data) if $longopts->{send_to_smolder};
+
} else {
eval { require TAP::Harness };
if ($@) {
Test::Harness::runtests(@tests);
exit;
- }
- else {
+ } else {
$harness = TAP::Harness->new({
verbosity => $ENV{HARNESS_VERBOSE}, merge => 0
});
}
- }
-
- $harness->runtests(@tests);
-
- if ($longopts->{send_to_smolder}) {
- send_archive_to_smolder();
+ $harness->runtests(@tests);
}
}
Modified: branches/gsoc_pdd09/t/library/p6object.t
==============================================================================
--- branches/gsoc_pdd09/t/library/p6object.t (original)
+++ branches/gsoc_pdd09/t/library/p6object.t Fri Jul 18 14:19:04 2008
@@ -25,8 +25,7 @@
test_namespace.'export_to'(curr_namespace, exports)
## set our plan
- .local int plan_tests
- plan(107)
+ plan(110)
## make sure we can load the P6object library
push_eh load_failed
@@ -115,13 +114,21 @@
is($S0, 'ABC', 'typeof ABC proto eq "ABC"')
$P0 = abcproto.'HOW'()
isa_ok($P0, 'P6metaclass', 'ABC proto .HOW')
- $I0 = $P0.'can'('foo')
- ok($I0, "ABC.HOW.can('foo')")
- $I0 = $P0.'can'('bar')
- nok($I0, "ABC.HOW.can('bar')")
+ $I0 = $P0.'can'(abcproto, 'foo')
+ ok($I0, "ABC.HOW.can(ABC, 'foo')")
+ $I0 = $P0.'can'(abcproto, 'bar')
+ nok($I0, "ABC.HOW.can(ABC, 'bar')")
$I0 = defined metaproto
nok($I0, 'ABC proto undefined')
+ ## create an anonymous class
+ $P0 = new 'Class'
+ $P1 = metaproto.'register'($P0)
+ isa_ok($P1, 'P6object', 'anonymous proto')
+ isa_ok($P1, 'P6protoobject', 'anonymous proto')
+ $S0 = $P1.'WHAT'()
+ is($S0, '', 'anonymous proto stringifies to empty string')
+
## try the default .new method on ABC protoobject
.local pmc abc
abc = abcproto.'new'()
