[Rt-commit] [svn] r1050 - in mzscheme: . Language-MzScheme
Language-MzScheme/lib/Language
Language-MzScheme/lib/Language/MzScheme Language-MzScheme/t
autrijus at pallas.eruditorum.org
autrijus at pallas.eruditorum.org
Thu Jun 10 02:19:28 EDT 2004
Author: autrijus
Date: Thu Jun 10 02:19:27 2004
New Revision: 1050
Added:
mzscheme/Language-MzScheme/lib/Language/MzScheme/
mzscheme/Language-MzScheme/lib/Language/MzScheme/Env.pm
mzscheme/Language-MzScheme/lib/Language/MzScheme/Object.pm
Removed:
mzscheme/Language-MzScheme/lib/Language/MzScheme_in.pm
Modified:
mzscheme/ (props changed)
mzscheme/Language-MzScheme/Makefile.PL
mzscheme/Language-MzScheme/README
mzscheme/Language-MzScheme/lib/Language/MzScheme.pm
mzscheme/Language-MzScheme/mzscheme.c
mzscheme/Language-MzScheme/mzscheme.i
mzscheme/Language-MzScheme/t/1-basic.t
Log:
----------------------------------------------------------------------
r5525 at not: autrijus | 2004-06-09T23:44:14.922672Z
* Backport to SWIG 1.3.19 and earlier versions.
* Starting of OOification of the APIs.
* Correctly passing scheme objects back and forth.
----------------------------------------------------------------------
Modified: mzscheme/Language-MzScheme/Makefile.PL
==============================================================================
--- mzscheme/Language-MzScheme/Makefile.PL (original)
+++ mzscheme/Language-MzScheme/Makefile.PL Thu Jun 10 02:19:27 2004
@@ -2,6 +2,7 @@
use strict;
use Config;
+use IPC::Open3;
use inc::Module::Install;
name('Language-MzScheme');
@@ -11,24 +12,14 @@
license('perl');
can_cc() or die "This module requires a C compiler";
-print << ".";
-Checking dependencies:
-- SWIG v1.3.20 or above - http://www.swig.org/
-- MzScheme v200 or above - http://plt-scheme.org/software/mzscheme/
-.
-
-`swig -ldflags` =~ /\w/
- or die "SWIG not found, aborting";
-`mzscheme --version` =~ /\d/
- or die "MzScheme not found, aborting";
-
-print << ".";
-...done.
-(If build fails, please check swig and mzscheme's versions manually.)
-.
+my ($swig_version) = (run('swig', '-version') =~ /([\d\.]+)/g)
+ or die "SWIG not found - http://www.swig.org/";
+
+my ($mz_version) = (run('mzscheme', '--version') =~ /([\d\.]+)/g)
+ or die "MzScheme not found - http://plt-scheme.org/software/mzscheme/";
my $plt_path = $ENV{PLT_PATH} || do {
- my $show = `mzc --ldl-show --help`
+ my $show = run(qw(mzc --ldl-show --help))
or die 'Cannot run mzc; please set $ENV{PLT_PATH}';
$show =~ m!\("([^"]+)/lib/!i
or die 'Cannot find PLT path; please set $ENV{PLT_PATH}';
@@ -38,26 +29,29 @@
my $include = "$plt_path/include";
-d $include or die "Cannot find 'include' dir under $plt_path; please set \$ENV{PLT_PATH}";
-make_hi();
+make_h();
system(
'swig',
"-I$include",
- qw(-module Language::MzScheme -noproxy -includeall -exportall -perl5 mzscheme.i)
+ ((v($swig_version) ge v('1.3.20')) ? qw(-noproxy -noruntime) : ()),
+ qw(-module Language::MzScheme -includeall -exportall -perl5 mzscheme.i)
);
+#make_c();
+
unlink('lib/Language/MzScheme_in.pm');
rename('MzScheme.pm' => 'lib/Language/MzScheme_in.pm');
makemaker_args(
- LIBS => "-L$plt_path/lib -lmzgc -lmzscheme",
+ LIBS => "-L$plt_path/lib -lmzgc -lmzscheme ".run(qw(swig -perl -ldflags)),
INC => "-I$include",
OBJECT => "mzscheme_wrap$Config{obj_ext}",
);
WriteAll( sign => 1 );
-sub make_hi {
+sub make_h {
open IN, "$include/scheme.h" or die $!;
open OUT, "> mzscheme_wrap.h" or die $!;
while (<IN>) {
@@ -81,4 +75,57 @@
}
close OUT;
close IN;
+
+ open IN, "$include/stypes.h" or die $!;
+ open OUT, ">> mzscheme_wrap.h" or die $!;
+ while (<IN>) {
+ print OUT $_;
+ }
+ close OUT;
+ close IN;
+}
+
+sub make_c {
+ local $/;
+ open IN, "mzscheme_wrap.c" or die $!;
+
+ my $text = '';
+ while (<IN>) {
+ if (/^static\s+swig_type_info\s+_swigt__p_(Scheme_(\w+))\[\]/o){
+ my $fromType = $1;
+ my $toType = "Language::MzScheme::".munge($1);
+ print << "END";
+static void *_p_${fromType}To_p_${toType}(void *x) {
+return (void *)(($toType *) (($fromType *) x));
+}
+END
+ s/("$toType\s*\*"\}),/$1,{"_p_$fromType",_p_${fromType}To_p_${toType}},/;
+ }
+ $text .= $_;
+ }
+
+ close IN;
+
+ open OUT, "> mzscheme_wrap.c" or die $!;
+ print OUT $text;
+ close OUT;
+}
+
+sub munge {
+ my $func = shift;
+ $func =~ s/_(?:[A-Z])//g;
+ $func;
+}
+
+sub v {
+ my $v = shift;
+ join('', map chr, $v =~ /(\d+)/g);
+}
+
+sub run {
+ my ($wtr, $rdr, $err);
+ my $pid = open3($wtr, $rdr, $err, @_);
+ my $out = join('', map $_ && readline($_), $rdr, $err);
+ chomp $out;
+ return $out;
}
Modified: mzscheme/Language-MzScheme/README
==============================================================================
--- mzscheme/Language-MzScheme/README (original)
+++ mzscheme/Language-MzScheme/README Thu Jun 10 02:19:27 2004
@@ -7,7 +7,7 @@
* Prerequisites
- The C++ Compiler used to compile your perl installation
-- SWIG v1.3.20 or above - http://www.swig.org/
+- SWIG v1.3 or above - http://www.swig.org/
- MzScheme v200 or above - http://plt-scheme.org/software/mzscheme/
* Installation
Modified: mzscheme/Language-MzScheme/lib/Language/MzScheme.pm
==============================================================================
--- mzscheme/Language-MzScheme/lib/Language/MzScheme.pm (original)
+++ mzscheme/Language-MzScheme/lib/Language/MzScheme.pm Thu Jun 10 02:19:27 2004
@@ -4,6 +4,8 @@
use strict;
use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
use Language::MzScheme_in;
+use Language::MzScheme::Env;
+use Language::MzScheme::Object;
@EXPORT_OK = @EXPORT;
@EXPORT = ();
@@ -46,6 +48,13 @@
$Language::MzScheme::Initialized++;
}
+foreach my $func (@EXPORT_OK) {
+ no strict 'refs';
+ my $idx = index(lc($func), 'scheme_');
+ $idx > -1 or next;
+ *{substr($func, $idx+7)} = sub { shift; goto &$func };
+}
+
1;
=head1 SEE ALSO
Added: mzscheme/Language-MzScheme/lib/Language/MzScheme/Env.pm
==============================================================================
--- (empty file)
+++ mzscheme/Language-MzScheme/lib/Language/MzScheme/Env.pm Thu Jun 10 02:19:27 2004
@@ -0,0 +1,41 @@
+package Language::MzScheme::Env;
+ at _p_Scheme_Env::ISA = __PACKAGE__;
+
+use strict;
+use constant S => "Language::MzScheme";
+
+sub eval {
+ my $self = shift;
+ UNIVERSAL::isa($_[0], S."::Object")
+ ? S->eval(@_, $self)
+ : S->eval_string(@_, $self);
+}
+
+sub define {
+ my ($self, $sym, $code) = @_;
+
+ # XXX - check prototype($code) to determine arity
+ my $prim = S->make_perl_prim_w_arity($code, $code, 0, -1);
+ S->add_global('perl-hello', $prim, $self);
+}
+
+sub export {
+ my ($self, $sym) = @_;
+
+ return sub {
+ require B;
+ my $list = join(
+ ' ',
+ map {
+ B::svref_2object(\$_)->FLAGS & ( B::SVf_IOK() | B::SVf_NOK() ) ? $_ : do {
+ my $str = $_;
+ $str =~ s/(?:["\\])/\\/g;
+ qq("$str");
+ };
+ } @_
+ );
+ $self->eval("($sym $list)");
+ };
+}
+
+1;
Added: mzscheme/Language-MzScheme/lib/Language/MzScheme/Object.pm
==============================================================================
--- (empty file)
+++ mzscheme/Language-MzScheme/lib/Language/MzScheme/Object.pm Thu Jun 10 02:19:27 2004
@@ -0,0 +1,41 @@
+package Language::MzScheme::Object;
+ at _p_Scheme_Object::ISA = __PACKAGE__;
+
+use strict;
+use constant S => "Language::MzScheme";
+use overload (
+ 'bool' => \&to_bool,
+ '""' => \&to_string,
+ '0+' => \&to_number,
+ fallback => 1,
+);
+
+sub display {
+ my $self = shift;
+ my $out = S->make_string_output_port();
+ S->display($self, $out);
+ return S->get_string_output($out);
+}
+
+sub to_bool {
+ my $self = shift;
+ !(S->VOIDP($self) || S->FALSEP($self));
+}
+
+sub to_string {
+ my $self = shift;
+ S->STRSYMP($self) ? S->STRSYM_VAL($self) :
+ S->CHARP($self) ? S->CHAR_VAL($self) :
+ S->VOIDP($self) ? undef :
+ S->FALSEP($self) ? '' :
+ $self->display;
+}
+
+sub to_number {
+ my $self = shift;
+ S->VOIDP($self) ? undef :
+ S->FALSEP($self) ? 0 :
+ $self->display;
+}
+
+1;
Modified: mzscheme/Language-MzScheme/mzscheme.c
==============================================================================
--- mzscheme/Language-MzScheme/mzscheme.c (original)
+++ mzscheme/Language-MzScheme/mzscheme.c Thu Jun 10 02:19:27 2004
@@ -18,13 +18,17 @@
Scheme_Object *
mzscheme_from_perl_scalar (Perl_Scalar sv) {
+ Scheme_Object *temp;
+
return (
+ SvROK(sv) ?
+ (SvTYPE(SvRV(sv)) == SVt_PVCV)
+ ? mzscheme_make_perl_prim_w_arity((Perl_Scalar)SvRV(sv), "", 0, -1) :
+ (SWIG_ConvertPtr(sv, (void **) &temp, SWIGTYPE_p_Scheme_Object, 0) >= 0)
+ ? temp : scheme_void :
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
+ SvPOK(sv) ? scheme_make_string( (char *)SvPV(sv, PL_na) ) : scheme_void
);
}
Modified: mzscheme/Language-MzScheme/mzscheme.i
==============================================================================
--- mzscheme/Language-MzScheme/mzscheme.i (original)
+++ mzscheme/Language-MzScheme/mzscheme.i Thu Jun 10 02:19:27 2004
@@ -57,6 +57,61 @@
int SCHEME_GENERICP(Scheme_Object *obj);
int SCHEME_CLOSUREP(Scheme_Object *obj);
+int SCHEME_CHARP(Scheme_Object *obj);
+int SCHEME_STRINGP(Scheme_Object *obj);
+int SCHEME_SYMBOLP(Scheme_Object *obj);
+int SCHEME_STRSYMP(Scheme_Object *obj);
+
+int SCHEME_BOOLP(Scheme_Object *obj);
+int SCHEME_FALSEP(Scheme_Object *obj);
+int SCHEME_TRUEP(Scheme_Object *obj);
+int SCHEME_EOFP(Scheme_Object *obj);
+int SCHEME_VOIDP(Scheme_Object *obj);
+
+char SCHEME_CHAR_VAL(Scheme_Object *obj);
+int SCHEME_INT_VAL(Scheme_Object *obj);
+double SCHEME_DBL_VAL(Scheme_Object *obj);
+float SCHEME_FLT_VAL(Scheme_Object *obj);
+#ifdef MZ_USE_SINGLE_FLOATS
+float SCHEME_FLOAT_VAL(Scheme_Object *obj);
+#else
+double SCHEME_FLOAT_VAL(Scheme_Object *obj);
+#endif
+char * SCHEME_STR_VAL(Scheme_Object *obj);
+char * SCHEME_STRTAG_VAL(Scheme_Object *obj);
+char * SCHEME_STRLEN_VAL(Scheme_Object *obj);
+char * SCHEME_SYM_VAL(Scheme_Object *obj);
+int SCHEME_SYM_LEN(Scheme_Object *obj);
+unsigned long SCHEME_SYMSTR_OFFSET(Scheme_Object *obj);
+char * SCHEME_STRSYM_VAL(Scheme_Object *obj);
+Scheme_Object* SCHEME_BOX_VAL(Scheme_Object *obj);
+Scheme_Object* SCHEME_CAR(Scheme_Object *obj);
+Scheme_Object* SCHEME_CDR(Scheme_Object *obj);
+Scheme_Object* SCHEME_CADR(Scheme_Object *obj);
+Scheme_Object* SCHEME_CAAR(Scheme_Object *obj);
+Scheme_Object* SCHEME_CDDR(Scheme_Object *obj);
+int SCHEME_VEC_SIZE(Scheme_Object *obj);
+Scheme_Object** SCHEME_VEC_ELS(Scheme_Object *obj);
+Scheme_Object** SCHEME_VEC_BASE(Scheme_Object *obj);
+
+/*
+#define SCHEME_ENVBOX_VAL(obj) (*((Scheme_Object **)(obj)))
+#define SCHEME_WEAK_BOX_VAL(obj) SCHEME_BOX_VAL(obj)
+
+#define SCHEME_PTR_VAL(obj) (((Scheme_Small_Object *)(obj))->u.ptr_val)
+#define SCHEME_PTR1_VAL(obj) ((obj)->u.two_ptr_val.ptr1)
+#define SCHEME_PTR2_VAL(obj) ((obj)->u.two_ptr_val.ptr2)
+#define SCHEME_IPTR_VAL(obj) ((obj)->u.ptr_int_val.ptr)
+#define SCHEME_LPTR_VAL(obj) ((obj)->u.ptr_long_val.ptr)
+#define SCHEME_INT1_VAL(obj) ((obj)->u.two_int_val.int1)
+#define SCHEME_INT2_VAL(obj) ((obj)->u.two_int_val.int2)
+#define SCHEME_PINT_VAL(obj) ((obj)->u.ptr_int_val.pint)
+#define SCHEME_PLONG_VAL(obj) ((obj)->u.ptr_long_val.pint)
+*/
+
+#define SCHEME_CPTR_VAL(obj) SCHEME_PTR1_VAL(obj)
+#define SCHEME_CPTR_TYPE(obj) ((char *)SCHEME_PTR2_VAL(obj))
+
Scheme_Config *scheme_config;
Scheme_Env *scheme_basic_env(void);
Modified: mzscheme/Language-MzScheme/t/1-basic.t
==============================================================================
--- mzscheme/Language-MzScheme/t/1-basic.t (original)
+++ mzscheme/Language-MzScheme/t/1-basic.t Thu Jun 10 02:19:27 2004
@@ -1,31 +1,33 @@
#!/usr/bin/perl
use strict;
-use Test;
-use FindBin;
-use Language::MzScheme ':all';
-
-BEGIN { plan tests => 5 }
-
-my $env = scheme_basic_env();
-ok(eval_scheme('(+ 1 2)'), 3);
-
-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: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 = (
- 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);
-}
+use Data::Dumper;
+use Test::More 'no_plan';
+
+use_ok('Language::MzScheme');
+
+my $env = Language::MzScheme->basic_env;
+my $obj = $env->eval(q{
+ (- 1 1)
+});
+
+isa_ok($obj, "Language::MzScheme::Object");
+ok($obj, 'to_boolean');
+is($obj, 0, 'to_number');
+is($obj.1, "01", 'to_string');
+
+$env->eval(q{
+ (define (square x) (* x x))
+});
+my $code = $env->export('square');
+is($code->(4), 16, 'export');
+
+sub hello { (Hello => map $_, reverse @_) };
+#sub hello { Hello => "$_[1]", "$_[0]" };
+$env->define('perl-hello', \&hello);
+is($env->eval('perl-hello'), '#<primitive:'.\&hello.'>');
+
+is($env->eval('(car (perl-hello "Scheme" "Perl"))'), 'Hello');
+is($env->eval('(cadr (perl-hello "Scheme" "Perl"))'), 'Perl');
+is($env->eval('(caddr (perl-hello "Scheme" "Perl"))'), 'Scheme');
+
More information about the Rt-commit
mailing list