Start of a t/jvm/01-continuations.t

Raku · Jun 15, 2013 · a6a7660 · a6a7660
1 parent b37f6f2
commit a6a7660
Show file tree

Hide file tree

Showing 2 changed files with 212 additions and 2 deletions.
diff --git a/t/jvm/01-continuations.t b/t/jvm/01-continuations.t
@@ -0,0 +1,210 @@
+#! nqp
+
+# continuations.
+
+plan(17);
+
+{
+    # unique objects
+    my $A := "A";
+    my $B := "B";
+
+    my int $run;
+    my $res := nqp::continuationreset(nqp::null(), {
+        $run++;
+        42;
+    });
+
+    ok($run == 1, 'reset runs argument once');
+    ok($res == 42, 'reset passes return value');
+
+    my $ex := '';
+    $run := 0;
+    # These tests are problematic.  Currently the continuation bubbles up to the nearest
+    # continuation barrier in invokeMain and dies there, with no chance to catch the
+    # resulting exception
+
+    # try {
+    #     nqp::continuationcontrol(0, nqp::null(), { $run++ });
+    #     CATCH { $ex := $! }
+    # }
+    # ok( $ex ~~ /'no matching'/, 'shift dies with no reset' );
+    # ok( $run == 0, '...without running argument' );
+
+    # $ex := '';
+    # try {
+    #     nqp::continuationreset($A, {
+    #         nqp::continuationcontrol(0, $B, { $run++ });
+    #     });
+    #     CATCH { $ex := $! }
+    # }
+    # ok( $ex ~~ /'no matching'/, 'control dies with mismatched reset' );
+
+    my str $log := '';
+    $log := $log ~ 1;
+    my $savecont;
+    my $shift_returned;
+
+    my $reset_returned := nqp::continuationreset(nqp::null(), {
+        $log := $log ~ 2;
+        $shift_returned := nqp::continuationcontrol(0, nqp::null(), -> $cont {
+            $log := $log ~ 3;
+            $savecont := $cont;
+            10;
+        });
+        $log := $log ~ 4;
+        $shift_returned * 2;
+    });
+    ok( $log eq '123', 'control returns from reset' );
+    ok( $savecont, 'got a continuation' );
+
+    ok( $reset_returned == 10, 'shift argument return value is reset return value' );
+
+    $log := '';
+    $reset_returned := nqp::continuationinvoke($savecont, { $log := $log ~ '5'; 15 });
+    ok( $log eq '54', 'continuation invoke "returns" from control');
+    ok( $shift_returned == 15, 'continuation invoke argument is shift return value' );
+    ok( $reset_returned == 30, 'reset block return value is continuation invoke return value' );
+
+    ok( nqp::continuationinvoke($savecont, {25}) == 50, 'continuation can be used more than once' );
+
+    ok( nqp::continuationreset($A, {
+        nqp::continuationcontrol(0, $A, -> $c { 42 });
+        10;
+    }) == 42, 'control may have a matching argument' );
+
+    ok( nqp::continuationreset($A, {
+        nqp::continuationreset($B, {
+            nqp::continuationcontrol(0, $A, -> $c { 42 });
+            10;
+        });
+        11;
+    }) == 42, 'control may match two levels up' );
+
+    ok( nqp::continuationreset($A, {
+        nqp::continuationreset($B, {
+            nqp::continuationcontrol(0, $B, -> $c { 42 });
+            10;
+        }) * 3;
+    }) == 126, 'control may match one level up' );
+
+    ok( nqp::continuationreset($A, {
+        nqp::continuationreset($B, {
+            nqp::continuationcontrol(0, nqp::null(), -> $c { 42 });
+            10;
+        }) * 3;
+    }) == 126, 'null shift matches innermost level');
+
+    my $cont := nqp::continuationreset($A, {
+        nqp::continuationreset($B, {
+            my $v := nqp::continuationcontrol(0, $A, -> $c { $c });
+            nqp::continuationcontrol(0, $B, -> $c { $v * 2 });
+            14;
+        }) * 3;
+    });
+    ok(nqp::continuationinvoke($cont, {10}) == 60, 'continuations can capture reset frames');
+}
+
+{
+    # should be 3 * 3 * 10 = 90
+    # will infinite loop if the clones are removed
+    my $cont := nqp::continuationreset(nqp::null(), {
+        3 * nqp::continuationcontrol(0, nqp::null(), -> $k { $k });
+    });
+    my $val := nqp::continuationinvoke(nqp::continuationclone($cont),
+        { nqp::continuationinvoke(nqp::continuationclone($cont), { 10 }) });
+
+    ok($val == 90, "restacking cont twice with clones works");
+}
+
+# scheme call/cc example: amby thing, needs to use control, not control0
+{
+    # for proper R5RS semantics, run this once wrapping your main function
+    sub run_main($f) {
+        nqp::continuationreset(nqp::null(), { $f() });
+    }
+
+    sub callcc($f) {
+        # first get the current continuation
+        nqp::continuationcontrol(1, nqp::null(), -> $dcont {
+            my $scheme_cont := -> $val {
+                # when the scheme continuation is invoked, we need to *replace*
+                # the current continuation with this one
+                nqp::continuationcontrol(1, nqp::null(), -> $c {
+                    nqp::continuationinvoke($dcont, { $val })
+                });
+            };
+            nqp::continuationinvoke($dcont, { $f($scheme_cont) });
+        });
+    }
+
+    my $backtrack_cont := sub ($ig) { nqp::die("Out of options!"); };
+
+    sub amb(*@options) {
+        my $old_back := $backtrack_cont;
+        my $here;
+        callcc(-> $c { $here := $c });
+        while @options {
+            my $next := nqp::shift(@options);
+            $backtrack_cont := $here;
+            return $next;
+        }
+        $old_back(0);
+    }
+
+    # 4-queens
+    my $queens := run_main({
+        sub check($a, $b, $dist) { amb() if $a-$b == $dist || $a-$b == -$dist || $a == $b }
+        my $q1 := amb(1,2,3,4);
+        my $q2 := amb(1,2,3,4);
+        check($q1,$q2,1);
+        my $q3 := amb(1,2,3,4);
+        check($q1,$q3,2);
+        check($q2,$q3,1);
+        my $q4 := amb(1,2,3,4);
+        check($q1,$q4,3);
+        check($q2,$q4,2);
+        check($q3,$q4,1);
+        "$q1$q2$q3$q4";
+    });
+
+    ok($queens eq '2413', 'n-queens callcc example');
+}
+
+# gather/take example
+{
+    my $SENTINEL := [];
+    sub yield($value) {
+        nqp::continuationcontrol(0, nqp::null(), -> $dcont {
+            [$value, { nqp::continuationinvoke($dcont, {0}) }]
+        });
+    }
+
+    sub start_iter($body) {
+        my $state := { $body(); yield($SENTINEL) };
+        -> {
+            my $pkt := nqp::continuationreset(nqp::null(), $state);
+            $state := $pkt[1];
+            $pkt[0];
+        }
+    }
+
+    sub mktree($l,$base) {
+        $l ?? [ mktree($l-1,$base~0), mktree($l-1,$base~1) ] !! $base;
+    }
+
+    sub walktree($tree) {
+        if nqp::istype($tree, NQPArray) {
+            for $tree { walktree($_) }
+        } else {
+            yield($tree);
+        }
+    }
+
+    my $iter := start_iter({ walktree(mktree(3,'')) });
+    my $rv;
+    my @list;
+    until ($rv := $iter()) =:= $SENTINEL { nqp::push(@list, $rv); }
+
+    ok(nqp::join('~',@list) eq '000~001~010~011~100~101~110~111', 'gather example works');
+}
diff --git a/tools/build/Makefile-JVM.in b/tools/build/Makefile-JVM.in
@@ -347,10 +347,10 @@ bootstrap-files: $(STAGE2_OUTPUT)
 ## testing
 
 test: all
-	prove -r --exec .@slash@$(RUNNER) t/nqp t/qregex t/p5regex t/qast t/serialization
+	prove -r --exec .@slash@$(RUNNER) t/nqp t/qregex t/p5regex t/qast t/serialization t/jvm
 
 test-loud: all
-	prove -r -v --exec .@slash@$(RUNNER) t/nqp t/qregex t/p5regex t/qast t/serialization
+	prove -r -v --exec .@slash@$(RUNNER) t/nqp t/qregex t/p5regex t/qast t/serialization t/jvm
 
 core-test: $(RUNNER)
 	prove -r --exec .@slash@$(RUNNER) t/nqp