CALLBACKS!

jnthn · Mar 29, 2010 · ecd16be · ecd16be
1 parent b474559
commit ecd16be
Show file tree

Hide file tree

Showing 5 changed files with 76 additions and 17 deletions.
diff --git a/nt/callback.t b/nt/callback.t
@@ -0,0 +1,32 @@
+# vim: ft=perl6
+
+plan(6);
+
+pir::load_bytecode("perl5.pir");
+
+sub p5($code) {
+    pir::compreg__ps("perl5").make_interp('sub {' ~ $code ~ '}')();
+}
+
+my $f1 := p5('5;');
+ok((+$f1(sub(){})) == 5, "can pass subs into p5");
+
+my $f2 := p5('my $f = shift; $f->(); 4');
+ok((+$f2(sub(){})) == 4, "can call subs passed into p5");
+
+my $v := 0;
+my $f3 := p5('my $f = shift; $f->(5); 2');
+$f3(sub(){ $v := 3 });
+ok($v == 3, "can pass values into callbacks");
+
+my $f4 := p5('my $f = shift; $f->()');
+ok((+$f4(sub(){7})) == 7, "can return values from callbacks");
+
+my $f5 := p5('my ($f,$v) = @_; $f->($v*$v) - 2');
+ok((+$f5(sub($x){(+$x)+2}, 16)) == 256, "can do arithmetic with wrapped values");
+
+$v := 0;
+my $f6 := p5('my $f = shift; sub { $f->(shift()+1) }');
+$f6($f6($f6($f6(sub($a) { $v := +$a }))))(9);
+ok($v == 13, "can deeply recurse between p5 and parrot");
+
diff --git a/src/pmc/bkmarshal.c b/src/pmc/bkmarshal.c
@@ -33,6 +33,10 @@ src/pmc/p5marshal.c - wrap P5 and Parrot calling conventions
 #include "bkmarshal.h"
 #include "parrot/oplib/ops.h"
 
+PARROT_WARN_UNUSED_RESULT
+PARROT_CANNOT_RETURN_NULL
+static CV *blizkost_wrap_callable(PARROT_INTERP, PMC *p5i, PMC *callable);
+
 /*
 
 =item C<SV *blizkost_marshal_arg(PARROT_INTERP, PerlInterpreter *my_perl, PMC *arg)>
@@ -46,8 +50,11 @@ Takes a PMC and marshals it into an SV that we can pass to Perl 5.
 PARROT_WARN_UNUSED_RESULT
 PARROT_CANNOT_RETURN_NULL
 SV *
-blizkost_marshal_arg(PARROT_INTERP, PerlInterpreter *my_perl, PMC *arg) {
+blizkost_marshal_arg(PARROT_INTERP, PMC *p5i, PMC *arg) {
     struct sv *result = NULL;
+    PerlInterpreter *my_perl;
+
+    GETATTR_P5Interpreter_my_perl(interp, p5i, my_perl);
 
     /* If it's a P5Scalar PMC, then we just fetch the SV from it - trivial
      * round-tripping. */
@@ -75,17 +82,21 @@ blizkost_marshal_arg(PARROT_INTERP, PerlInterpreter *my_perl, PMC *arg) {
         char *c_str = Parrot_str_to_cstring(interp, VTABLE_get_string(interp, arg));
         result = sv_2mortal(newSVpv(c_str, strlen(c_str)));
     }
+    else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "Sub"))) {
+        CV *wrapper = blizkost_wrap_callable(interp, p5i, arg);
+        result = sv_2mortal(newRV_inc((SV*)wrapper));
+    }
     else if ( VTABLE_does(interp, arg, CONST_STRING(interp, "array"))) {
         PMC *iter;
         struct av *array = newAV();
         iter = VTABLE_get_iter(interp, arg);
         while (VTABLE_get_bool(interp, iter)) {
              PMC *item = VTABLE_shift_pmc(interp, iter);
              struct sv *marshaled =
-                blizkost_marshal_arg(interp, my_perl, item);
+                blizkost_marshal_arg(interp, p5i, item);
              av_push( array, marshaled);
         }
-        result = newRV_inc(array);
+        result = newRV_inc((SV*)array);
 
     }
     else if ( VTABLE_does(interp, arg, CONST_STRING(interp, "hash"))) {
@@ -96,11 +107,11 @@ blizkost_marshal_arg(PARROT_INTERP, PerlInterpreter *my_perl, PMC *arg) {
         for(i = 0; i < n; i++) {
             STRING *s = VTABLE_shift_string(interp, iter);
             char *c_str = Parrot_str_to_cstring(interp, s);
-            struct sv *val = blizkost_marshal_arg(interp, my_perl,
+            struct sv *val = blizkost_marshal_arg(interp, p5i,
                     VTABLE_get_pmc_keyed_str(interp, arg, s));
             hv_store(hash, c_str, strlen(c_str), val, 0);
         }
-        result = newRV_inc(hash);
+        result = newRV_inc((SV*)hash);
     }
     else {
         Parrot_ex_throw_from_c_args(interp, NULL, 1,
@@ -163,7 +174,7 @@ blizkost_return_from_invoke(PARROT_INTERP, void *next) {
 }
 
 int
-blizkost_slurpy_to_stack(PARROT_INTERP, PerlInterpreter *my_perl,
+blizkost_slurpy_to_stack(PARROT_INTERP, PMC *p5i, PerlInterpreter *my_perl,
         PMC *positional, PMC *named) {
     int num_pos, i, stkdepth;
     PMC *iter;
@@ -175,7 +186,7 @@ blizkost_slurpy_to_stack(PARROT_INTERP, PerlInterpreter *my_perl,
     num_pos = VTABLE_elements(interp, positional);
     for (i = 0; i < num_pos; i++) {
         PMC *pos_arg = VTABLE_get_pmc_keyed_int(interp, positional, i);
-        XPUSHs(blizkost_marshal_arg(interp, my_perl, pos_arg));
+        XPUSHs(blizkost_marshal_arg(interp, p5i, pos_arg));
         stkdepth++;
     }
 
@@ -187,7 +198,7 @@ blizkost_slurpy_to_stack(PARROT_INTERP, PerlInterpreter *my_perl,
         PMC    *arg_value  = VTABLE_get_pmc_keyed_str(interp, named, arg_name);
         char   *c_arg_name = Parrot_str_to_cstring(interp, arg_name);
         XPUSHs(sv_2mortal(newSVpv(c_arg_name, strlen(c_arg_name))));
-        XPUSHs(blizkost_marshal_arg(interp, my_perl, arg_value));
+        XPUSHs(blizkost_marshal_arg(interp, p5i, arg_value));
         stkdepth += 2;
     }
     PUTBACK;
@@ -210,7 +221,7 @@ blizkost_call_in(PARROT_INTERP, PMC *p5i, SV *what, U32 mode, PMC *positp,
         PUSHMARK(SP);
 
         PUTBACK;
-        blizkost_slurpy_to_stack(interp, my_perl, positp, namedp);
+        blizkost_slurpy_to_stack(interp, p5i, my_perl, positp, namedp);
 
         /* Invoke the methods. */
         num_returns = call_sv(what, mode);
@@ -297,7 +308,6 @@ blizkost_bind_pmc_to_sv(PerlInterpreter *my_perl, SV *sv,
     Parrot_pmc_gc_register(interp, target);
 }
 
-#if 0
 /* can't really use xsubpp here... */
 static
 XS(blizkost_callable_trampoline)
@@ -315,20 +325,35 @@ XS(blizkost_callable_trampoline)
 
     PERL_UNUSED_VAR(ax);
     SP -= items;
+    PUTBACK;
 
     args = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
     for (i = 0; i < items; i++) {
         SV *svarg = ST(i);
-        PMC *pmcarg = blizkost_wrap_sv(interp, p5i, result_sv);
+        PMC *pmcarg = blizkost_wrap_sv(interp, p5i, svarg);
         VTABLE_unshift_pmc(interp, args, pmcarg);
     }
 
     Parrot_pcc_invoke_sub_from_c_args(interp, callable, "Pf->PsPsn",
             args, &posret, &namret);
 
-    blizkost_slurpy_to_stack(interp, my_perl, posret, namret);
+    blizkost_slurpy_to_stack(interp, p5i, my_perl, posret, namret);
 
-    PUTBACK;
+    SPAGAIN;
 }
 
-#endif
+PARROT_WARN_UNUSED_RESULT
+PARROT_CANNOT_RETURN_NULL
+static CV *
+blizkost_wrap_callable(PARROT_INTERP, PMC *p5i, PMC *callable) {
+    PerlInterpreter *my_perl;
+    CV *cv;
+
+    GETATTR_P5Interpreter_my_perl(interp, p5i, my_perl);
+
+    cv = newXS("blizkost_xs_wrapper", blizkost_callable_trampoline,
+            "bkmarshal.c");
+    blizkost_bind_pmc_to_sv(my_perl, (SV*)cv, interp, p5i, callable);
+
+    return cv;
+}
diff --git a/src/pmc/bkmarshal.h b/src/pmc/bkmarshal.h
@@ -22,7 +22,7 @@ src/pmc/p5marshal.c - wrap P5 and Parrot calling conventions
 
 PARROT_WARN_UNUSED_RESULT
 PARROT_CANNOT_RETURN_NULL
-SV *blizkost_marshal_arg(PARROT_INTERP, PerlInterpreter *my_perl, PMC *arg);
+SV *blizkost_marshal_arg(PARROT_INTERP, PMC *p5i, PMC *arg);
 
 PARROT_WARN_UNUSED_RESULT
 PARROT_CANNOT_RETURN_NULL
@@ -32,7 +32,7 @@ PARROT_WARN_UNUSED_RESULT
 PARROT_CANNOT_RETURN_NULL
 opcode_t *blizkost_return_from_invoke(PARROT_INTERP, void *next);
 
-int blizkost_slurpy_to_stack(PARROT_INTERP, PerlInterpreter *my_perl,
+int blizkost_slurpy_to_stack(PARROT_INTERP, PMC *p5i, PerlInterpreter *my_perl,
         PMC *positional, PMC *named);
 
 void blizkost_call_in(PARROT_INTERP, PMC *p5i, SV *what, U32 mode,

diff --git a/src/pmc/p5interpreter.pmc b/src/pmc/p5interpreter.pmc
@@ -93,6 +93,8 @@ Set up P5Interpreter PMC.
         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
         perl_run(my_perl);
         SET_ATTR_my_perl(interp, SELF, my_perl);
+        SET_ATTR_self(interp, SELF, SELF);
+        SET_ATTR_parrot_interp(interp, SELF, interp);
 
         /* We turn on auto-flush to avoid oddness in interactions between
          * IO systems. */

diff --git a/src/pmc/p5scalar.pmc b/src/pmc/p5scalar.pmc
@@ -70,7 +70,7 @@ Returns the integer value of the SV.
 
 /*
 
-=item C<NUMVAL get_integer()>
+=item C<NUMVAL get_number()>
 
 Returns the number value of the SV.