Skip to content
Browse files

Return values from callbacks seem to work now as well.

Tests and some small tweaks to the code.
  • Loading branch information...
1 parent 2680acd commit 79429d93b9eb1287a2b7e946dbc4707f89210ca8 @arnsholt arnsholt committed Jul 30, 2012
Showing with 54 additions and 5 deletions.
  1. +4 −4 lib/NativeCall.pm6
  2. +21 −0 t/08-callbacks.c
  3. +29 −1 t/08-callbacks.t
View
8 lib/NativeCall.pm6
@@ -27,7 +27,7 @@ sub param_hash_for(Parameter $p, :$with-typeobj) {
elsif $type ~~ Callable {
nqp::bindkey($result, 'type', nqp::unbox_s(type_code_for($p.type)));
my $info := param_list_for($p.sub_signature, :with-typeobj);
- nqp::unshift($info, return_hash_for($type));
+ nqp::unshift($info, return_hash_for($p.sub_signature));
nqp::bindkey($result, 'callback_args', $info);
}
else {
@@ -47,9 +47,9 @@ sub param_list_for(Signature $sig, :$with-typeobj) {
}
# Builds a hash of type information for the specified return type.
-sub return_hash_for(&r) {
+sub return_hash_for(Signature $s) {
my Mu $result := nqp::hash();
- my $returns := &r.returns;
+ my $returns := $s.returns;
if $returns ~~ Str {
my $enc := &r.?native_call_encoded() || 'utf8';
nqp::bindkey($result, 'type', nqp::unbox_s(string_encoding_to_nci_type($enc)));
@@ -116,7 +116,7 @@ my role Native[Routine $r, Str $libname] {
nqp::unbox_s($r.name), # symbol to call
nqp::unbox_s($conv), # calling convention
$arg_info,
- return_hash_for($r));
+ return_hash_for($r.signature));
$!setup = 1;
}
nqp::nativecall(nqp::p6decont(map_return_type($r.returns)), self,
View
21 t/08-callbacks.c
@@ -1,4 +1,5 @@
#include <stdlib.h>
+#include <stdio.h>
#include <string.h>
#ifdef WIN32
@@ -32,3 +33,23 @@ DLLEXPORT void TakeStructCallback(void (*cb)(Struct *)) {
s->ival = -42;
cb(s);
}
+
+DLLEXPORT void CheckReturnsFloat(double (*cb)()) {
+ double num = cb();
+ if(num != 1.23) printf("not ");
+ printf("ok - num callback return value\n");
+}
+
+DLLEXPORT void CheckReturnsStr(char *(*cb)()) {
+ char *str = cb();
+ if(strcmp(str, "Herps and derps")) printf("not ");
+ printf("ok - string callback return value\n");
+}
+
+DLLEXPORT void CheckReturnsStruct(Struct *(*cb)()) {
+ Struct *s = cb();
+ if(s->ival != 314) printf("not ");
+ printf("ok - struct (intval) callback return value\n");
+ if(strcmp(s->str, "Tweedledum, tweedledee")) printf("not ");
+ printf("ok - struct (string) callback return value\n");
+}
View
30 t/08-callbacks.t
@@ -3,20 +3,29 @@ use t::CompileTestLib;
use NativeCall;
use Test;
-plan(5);
+plan(9);
compile_test_lib('08-callbacks');
class Struct is repr('CStruct') {
has Str $.str;
has int $.ival;
+
+ method init {
+ $!str := 'Tweedledum, tweedledee';
+ $!ival = 314;
+ }
}
sub TakeACallback(&cb()) is native('./08-callbacks') { * }
sub TakeIntCallback(&cb(int)) is native('./08-callbacks') { * }
sub TakeStringCallback(&cb(Str)) is native('./08-callbacks') { * }
sub TakeStructCallback(&cb(Struct)) is native('./08-callbacks') { * }
+sub CheckReturnsFloat(&cb(--> num)) is native('./08-callbacks') { * }
+sub CheckReturnsStr(&cb(--> Str)) is native('./08-callbacks') { * }
+sub CheckReturnsStruct(&cb(--> Struct)) is native('./08-callbacks') { * }
+
sub simple_callback() {
pass 'simple callback';
}
@@ -34,9 +43,28 @@ sub struct_callback(Struct $struct) {
is $struct.ival, -42, 'struct callback int argument';
}
+sub return_float() returns num {
+ return 1.23e0;
+}
+
+sub return_str() returns Str {
+ return 'Herps and derps';
+}
+
+sub return_struct() returns Struct {
+ my Struct $struct .= new;
+ $struct.init;
+
+ return $struct;
+}
+
TakeACallback(&simple_callback);
TakeIntCallback(&int_callback);
TakeStringCallback(&str_callback);
TakeStructCallback(&struct_callback);
+CheckReturnsFloat(&return_float);
+CheckReturnsStr(&return_str);
+CheckReturnsStruct(&return_struct);
+
# vim:ft=perl6

0 comments on commit 79429d9

Please sign in to comment.
Something went wrong with that request. Please try again.