Implement immediate blocktype handling; test it.

Raku · May 12, 2012 · 105ff32 · 105ff32
1 parent e3485a5
commit 105ff32
Show file tree

Hide file tree

Showing 2 changed files with 94 additions and 56 deletions.
diff --git a/src/QAST/Compiler.nqp b/src/QAST/Compiler.nqp
@@ -156,77 +156,105 @@ class QAST::Compiler is HLL::Compiler {
     proto method as_post(*@args, *%_) { * }
 
     multi method as_post(QAST::Block $node) {
-        # Block gets completely fresh registers, and fresh BlockInfo.
-        my $*REGALLOC := RegAlloc.new();
-        my $*BLOCKRA  := $*REGALLOC;
-        my $*BINDVAL  := 0;
-        my $outer     := try $*BLOCK;
-        my $block     := BlockInfo.new($node, $outer);
-
-        # First need to compile all of the statements.
-        my $stmts;
+        # Build the POST::Sub.
+        my $sub;
         {
-            my $*BLOCK := $block;
-            $stmts := self.compile_all_the_stmts($node.list);
-        }
-
-        # Generate parameter handling code.
-        my $decls := self.post_new('Ops');
-        my %lex_params;
-        for $block.params {
-            my @param := ['.param'];
+            # Block gets completely fresh registers, and fresh BlockInfo.
+            my $*REGALLOC := RegAlloc.new();
+            my $*BLOCKRA  := $*REGALLOC;
+            my $*BINDVAL  := 0;
+            my $outer     := try $*BLOCK;
+            my $block     := BlockInfo.new($node, $outer);
 
-            if $_.scope eq 'local'{
-                nqp::push(@param, $block.local_type_long($_.name));
-                nqp::push(@param, $_.name);
-            }
-            else {
-                my $reg := $block.lex_reg($_.name);
-                nqp::push(@param, $block.lexical_type_long($_.name));
-                nqp::push(@param, $reg);
-                %lex_params{$_.name} := $reg;
+            # First need to compile all of the statements.
+            my $stmts;
+            {
+                my $*BLOCK := $block;
+                $stmts := self.compile_all_the_stmts($node.list);
             }
 
-            if $_.slurpy {
-                nqp::push(@param, ':slurpy');
-                if $_.named {
-                    nqp::push(@param, ':named');
+            # Generate parameter handling code.
+            my $decls := self.post_new('Ops');
+            my %lex_params;
+            for $block.params {
+                my @param := ['.param'];
+
+                if $_.scope eq 'local'{
+                    nqp::push(@param, $block.local_type_long($_.name));
+                    nqp::push(@param, $_.name);
+                }
+                else {
+                    my $reg := $block.lex_reg($_.name);
+                    nqp::push(@param, $block.lexical_type_long($_.name));
+                    nqp::push(@param, $reg);
+                    %lex_params{$_.name} := $reg;
+                }
+
+                if $_.slurpy {
+                    nqp::push(@param, ':slurpy');
+                    if $_.named {
+                        nqp::push(@param, ':named');
+                    }
+                }
+                elsif $_.named {
+                    nqp::push(@param, ':named(' ~ self.escape($_.named) ~ ')');
                 }
+
+                $decls.push_pirop(pir::join(' ', @param));
+            }
+
+            # Generate declarations.
+            for $block.lexicals {
+                $decls.push_pirop('.lex ' ~ self.escape($_.name) ~ ', ' ~ $block.lex_reg($_.name));
+            }
+            for %lex_params {
+                $decls.push_pirop('.lex ' ~ self.escape($_.key) ~ ', ' ~ $_.value);
             }
-            elsif $_.named {
-                nqp::push(@param, ':named(' ~ self.escape($_.named) ~ ')');
+            for $block.locals {
+                $decls.push_pirop('.local ' ~ $block.local_type_long($_.name) ~ ' ' ~ $_.name);
             }
 
-            $decls.push_pirop(pir::join(' ', @param));
+            # Wrap all up in a POST::Sub.
+            $sub := self.post_new('Sub');
+            $sub.push($decls);
+            $sub.push($stmts);
+            $sub.push_pirop(".return (" ~ $stmts.result ~ ")");
+
+            # Set compilation unit ID and, if applicable, outer.
+            $sub.subid($node.cuid);
+            if nqp::istype($block.outer, BlockInfo) {
+                $sub.pirflags(':anon :outer(' ~ self.escape($block.outer.qast.cuid) ~ ')');
+            }
+            else {
+                $sub.pirflags(':anon');
+            }
         }
 
-        # Generate declarations.
-        for $block.lexicals {
-            $decls.push_pirop('.lex ' ~ self.escape($_.name) ~ ', ' ~ $block.lex_reg($_.name));
-        }
-        for %lex_params {
-            $decls.push_pirop('.lex ' ~ self.escape($_.key) ~ ', ' ~ $_.value);
-        }
-        for $block.locals {
-            $decls.push_pirop('.local ' ~ $block.local_type_long($_.name) ~ ' ' ~ $_.name);
+        # If we are at the top level, we'll immediately return.
+        unless nqp::istype((try $*BLOCK), BlockInfo) {
+            return $sub;
         }
 
-        # Wrap all up in a POST::Sub.
-        my $sub := self.post_new('Sub');
-        $sub.push($decls);
-        $sub.push($stmts);
-        $sub.push_pirop(".return (" ~ $stmts.result ~ ")");
-
-        # Set compilation unit ID and, if applicable, outer.
-        $sub.subid($node.cuid);
-        if nqp::istype($block.outer, BlockInfo) {
-            $sub.pirflags(':anon :outer(' ~ self.escape($block.outer.qast.cuid) ~ ')');
+        # What we evaluate to depends on whether it's a declaration or an
+        # immediate.
+        my $ops := self.post_new('Ops');
+        $ops.push($sub);
+        if $node.blocktype eq 'immediate' {
+            # Look up and capture the block.
+            my $breg := $*REGALLOC.fresh_p();
+            $ops.push_pirop(".const 'Sub' $breg = '" ~ $node.cuid() ~ "'");
+            $ops.push_pirop("capture_lex", $breg);
+
+            # Pick a result register.
+            my $rtype := nqp::lc(type_to_register_type($node.returns));
+            my $rreg := $*REGALLOC."fresh_$rtype"();
+            $ops.push_pirop('call', $breg, :result($rreg));
+            $ops.result($rreg);
         }
         else {
-            $sub.pirflags(':anon');
+
         }
-
-        $sub
+        $ops
     }
 
     multi method as_post(QAST::Stmts $node) {

diff --git a/t/qast/qast.t b/t/qast/qast.t
@@ -318,3 +318,13 @@ is_qast_args(
     [16, 22],
     38,
     'two lexical int args declared/used simultaneously');
+
+is_qast(
+    QAST::Block.new(
+        QAST::Block.new(
+            :blocktype('immediate'),
+            QAST::IVal.new( :value(2000) )
+        )
+    ),
+    2000,
+    'immediate blocktype');