[svn:parrot] r35637 - in trunk/languages/perl6/src: builtins classes parser

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