[Rt-commit] [svn] r1037 - in mzscheme: . Language-MzScheme Language-MzScheme/t

[autrijus at pallas.eruditorum.org]

Author: autrijus
Date: Tue Jun  8 18:20:53 2004
New Revision: 1037

Modified:
   mzscheme/   (props changed)
   mzscheme/Language-MzScheme/mzscheme.c
   mzscheme/Language-MzScheme/mzscheme.h
   mzscheme/Language-MzScheme/mzscheme.i
   mzscheme/Language-MzScheme/t/1-basic.t
Log:
 ----------------------------------------------------------------------
 r5486 at not:  autrijus | 2004-06-08T20:34:31.923716Z
 
 * mzscheme_make_perl_prim_w_arity now takes code references!
 ----------------------------------------------------------------------
 r5487 at not:  autrijus | 2004-06-08T22:21:12.926828Z
 
 * All four ways of message passing are now completed.
 ----------------------------------------------------------------------


Modified: mzscheme/Language-MzScheme/mzscheme.c
==============================================================================
--- mzscheme/Language-MzScheme/mzscheme.c	(original)
+++ mzscheme/Language-MzScheme/mzscheme.c	Tue Jun  8 18:20:53 2004
@@ -8,7 +8,8 @@
 }
 
 Scheme_Object *
-mzscheme_make_perl_prim_w_arity (const char *cv_ref, const char *name, int mina, int maxa) {
+mzscheme_make_perl_prim_w_arity (Perl_Scalar cv_ref, const char *name, int mina, int maxa) {
+    SvREFCNT_inc((SV *)cv_ref);
     return scheme_make_closed_prim_w_arity(
         &_mzscheme_closed_prim_CV,
         (void *)cv_ref, name, mina, maxa
@@ -16,11 +17,52 @@
 }
 
 Scheme_Object *
+mzscheme_from_perl_scalar (Perl_Scalar sv) {
+    return (
+        SvIOK(sv) ? scheme_make_integer_value( (int)SvIV(sv) ) :
+        SvNOK(sv) ? scheme_make_double( (double)SvNV(sv) ) :
+        SvPOK(sv) ? scheme_make_string( (char *)SvPV(sv, PL_na) ) :
+        (SvTYPE(sv) == SVt_PVCV)
+            ? mzscheme_make_perl_prim_w_arity((Perl_Scalar)sv, "", 0, -1)
+            : scheme_undefined
+    );
+}
+
+Scheme_Object *
 _mzscheme_closed_prim_CV (void *callback, int argc, Scheme_Object **argv) {
     dSP ;
+    Scheme_Object **return_values;
+    I32 count, i;
+
+    ENTER ;
+    SAVETMPS;
+
     PUSHMARK(SP) ;
-    call_pv((const char*)callback, G_DISCARD|G_NOARGS) ;
-    return scheme_undefined;
+    EXTEND(SP, argc);
+
+    for (i = 0; i < argc; i++) {
+        SV *sv = sv_newmortal();
+        SWIG_MakePtr(sv, (void *)argv[i], SWIGTYPE_p_Scheme_Object, 0);
+        PUSHs(sv);
+    }
+
+    PUTBACK ;
+
+    count = call_sv((SV*)callback, G_ARRAY);
+
+    SPAGAIN ;
+
+    return_values = (Scheme_Object **) malloc((count+2)*sizeof(Scheme_Object *));
+
+    for (i = count - 1; i >= 0 ; i--) {
+        return_values[i] = mzscheme_from_perl_scalar(POPs);
+    }
+
+    PUTBACK ;
+    FREETMPS ;
+    LEAVE ;
+
+    return scheme_build_list((int)count, return_values);
 }
 
 AV *

Modified: mzscheme/Language-MzScheme/mzscheme.h
==============================================================================
--- mzscheme/Language-MzScheme/mzscheme.h	(original)
+++ mzscheme/Language-MzScheme/mzscheme.h	Tue Jun  8 18:20:53 2004
@@ -1,3 +1,4 @@
 
+typedef SV* Perl_Scalar;
 AV*                 _mzscheme_objects_AV (Scheme_Object ** objects);
 Scheme_Object*      _mzscheme_closed_prim_CV (void *d, int argc, Scheme_Object **argv);

Modified: mzscheme/Language-MzScheme/mzscheme.i
==============================================================================
--- mzscheme/Language-MzScheme/mzscheme.i	(original)
+++ mzscheme/Language-MzScheme/mzscheme.i	Tue Jun  8 18:20:53 2004
@@ -4,8 +4,13 @@
 #include "mzscheme.c"
 %}
 
-void            mzscheme_init();
-Scheme_Object*  mzscheme_make_perl_prim_w_arity(const char *cv_ref, const char *name, int mina, int maxa);
+%typemap(in) Perl_Scalar {
+    $1 = (void *)$input;
+}
+
+%typemap(out) Perl_Scalar {
+    $result = (SV *)$1;
+}
 
 %typemap(in) Scheme_Object ** {
     AV *tempav;
@@ -36,6 +41,9 @@
     argvi++;
 }
 
+void            mzscheme_init();
+Scheme_Object*  mzscheme_make_perl_prim_w_arity(Perl_Scalar cv_ref, const char *name, int mina, int maxa);
+
 Scheme_Type     SCHEME_TYPE(Scheme_Object *obj);
 int             SCHEME_PROCP(Scheme_Object *obj);
 int             SCHEME_SYNTAXP(Scheme_Object *obj);

Modified: mzscheme/Language-MzScheme/t/1-basic.t
==============================================================================
--- mzscheme/Language-MzScheme/t/1-basic.t	(original)
+++ mzscheme/Language-MzScheme/t/1-basic.t	Tue Jun  8 18:20:53 2004
@@ -5,23 +5,27 @@
 use FindBin;
 use Language::MzScheme;
 
-BEGIN { plan tests => 3 }
+BEGIN { plan tests => 4 }
 
 my $env = scheme_basic_env();
 ok(eval_scheme('(+ 1 2)'), 3);
 
-my $hello;
-sub perl_hello { $hello = "Hello from Perl!" };
-my $prim = mzscheme_make_perl_prim_w_arity('perl_hello', 'perl-hello', 0, 0);
+sub perl_hello { (Hello => reverse map eval_scheme($_), @_) };
+my $prim = mzscheme_make_perl_prim_w_arity(\&perl_hello, "perl:procedure", 0, -1);
 scheme_add_global('perl-hello', $prim, $env);
-ok(eval_scheme('perl-hello'), '#<primitive:perl-hello>');
 
-eval_scheme('(perl-hello)');
-ok($hello, "Hello from Perl!");
+ok(eval_scheme('perl-hello'), '#<primitive:perl:procedure>');
+ok(eval_scheme('(car (perl-hello "Scheme" "Perl"))'), 'Hello');
+ok(eval_scheme('(cadr (perl-hello "Scheme" "Perl"))'), 'Perl');
+ok(eval_scheme('(caddr (perl-hello "Scheme" "Perl"))'), 'Scheme');
 
 sub eval_scheme {
     my $out = scheme_make_string_output_port();
-    my $val = scheme_eval_string($_[0], $env);
+    my $val = (
+        UNIVERSAL::isa($_[0], '_p_Scheme_Object')
+            ? scheme_eval($_[0], $env)
+            : scheme_eval_string($_[0], $env)
+    );
     scheme_display($val, $out);
     return scheme_get_string_output($out);
 }