Author: jonathan
Date: Fri Jan 16 09:35:23 2009
New Revision: 35637
Modified:
trunk/languages/perl6/src/builtins/guts.pir
trunk/languages/perl6/src/classes/Code.pir
trunk/languages/perl6/src/classes/List.pir
trunk/languages/perl6/src/parser/actions.pm
Log:
[rakudo] Re-bless Parrot subs into Block, (Perl6)Sub or Method, so .WHAT
answers correctly on them.
Modified: trunk/languages/perl6/src/builtins/guts.pir
==============================================================================
--- trunk/languages/perl6/src/builtins/guts.pir (original)
+++ trunk/languages/perl6/src/builtins/guts.pir Fri Jan 16 09:35:23 2009
@@ -982,6 +982,25 @@
.return (result)
.end
+
+=item !fixup_routine_type(sub, new_type)
+
+Reblesses a sub into a new type.
+
+=cut
+
+.sub '!fixup_routine_type'
+ .param pmc sub
+ .param string new_type_name
+
+ # Create the correct object and rebless the sub into that class.
+ .local pmc new_type
+ new_type = get_hll_global new_type_name
+ $P0 = new_type.'new'()
+ $P0 = typeof $P0
+ rebless_subclass sub, $P0
+.end
+
=back
=cut
Modified: trunk/languages/perl6/src/classes/Code.pir
==============================================================================
--- trunk/languages/perl6/src/classes/Code.pir (original)
+++ trunk/languages/perl6/src/classes/Code.pir Fri Jan 16 09:35:23 2009
@@ -16,7 +16,7 @@
.sub 'onload' :anon :load :init
.local pmc p6meta, codeproto
p6meta = get_hll_global ['Perl6Object'], '$!P6META'
- codeproto = p6meta.'new_class'('Code', 'parent'=>'Any')
+ codeproto = p6meta.'new_class'('Code', 'parent'=>'Sub Any')
$P0 = get_hll_global 'Callable'
$P0 = $P0.'!select'()
p6meta.'add_role'($P0, 'to'=>codeproto)
@@ -100,21 +100,6 @@
.return ('{ ... }')
.end
-=item WHAT()
-
-Gets the proto-object for this value.
-
-=cut
-
-.sub 'WHAT' :method
- $P0 = getprop '$!proto', self
- if null $P0 goto block
- .return ($P0)
- block:
- $P0 = get_hll_global 'Block'
- .return ($P0)
-.end
-
=item signature()
Gets the signature for the block, or returns Failure if it lacks one.
Modified: trunk/languages/perl6/src/classes/List.pir
==============================================================================
--- trunk/languages/perl6/src/classes/List.pir (original)
+++ trunk/languages/perl6/src/classes/List.pir Fri Jan 16 09:35:23 2009
@@ -405,7 +405,7 @@
.namespace []
-.sub 'uniq' :multi(Sub)
+.sub 'uniq' :multi('Block')
.param pmc comparer
.param pmc values :slurpy
values.'!flatten'()
Modified: trunk/languages/perl6/src/parser/actions.pm
==============================================================================
--- trunk/languages/perl6/src/parser/actions.pm (original)
+++ trunk/languages/perl6/src/parser/actions.pm Fri Jan 16 09:35:23 2009
@@ -91,7 +91,11 @@
method block($/) {
- make $( $<statement_block> );
+ my $past := $( $<statement_block> );
+ unless $past<pkgdecl> {
+ set_block_type($past, 'Block');
+ }
+ make $past;
}
@@ -872,9 +876,11 @@
my $past;
if $key eq 'sub' {
$past := $($<routine_def>);
+ set_block_type($past, 'Sub');
}
elsif $key eq 'method' {
$past := $($<method_def>);
+ set_block_type($past, 'Method');
}
elsif $key eq 'submethod' {
$/.panic('submethod declarations not yet implemented');
@@ -2789,6 +2795,24 @@
}
+# Adds to the loadinit to set the type of a block.
+sub set_block_type($block, $type) {
+ # If the block already has a type node, edit it.
+ if $block<block_class_type> {
+ $block<block_class_type>[1] := $type;
+ }
+ else {
+ my $set_type := PAST::Op.new(
+ :pasttype('call'),
+ :name('!fixup_routine_type'),
+ PAST::Var.new( :name('block'), :scope('register') ),
+ $type
+ );
+ $block<block_class_type> := $set_type;
+ $block.loadinit().push($set_type);
+ }
+}
+
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
