[Rt-commit] [svn] r1059 - in mzscheme: . Language-MzScheme
Language-MzScheme/lib/Language
Language-MzScheme/lib/Language/MzScheme
Language-MzScheme/script Language-MzScheme/t
autrijus at pallas.eruditorum.org
autrijus at pallas.eruditorum.org
Sun Jun 13 00:09:53 EDT 2004
Author: autrijus
Date: Sun Jun 13 00:09:52 2004
New Revision: 1059
Added:
mzscheme/Language-MzScheme/script/
mzscheme/Language-MzScheme/script/mzperl
mzscheme/Language-MzScheme/t/2-context.t
mzscheme/Language-MzScheme/t/3-object.t
mzscheme/Language-MzScheme/t/4-data.t
mzscheme/Language-MzScheme/t/5-perl.t
mzscheme/Language-MzScheme/t/6-error.t
Modified:
mzscheme/ (props changed)
mzscheme/Language-MzScheme/MANIFEST
mzscheme/Language-MzScheme/Makefile.PL
mzscheme/Language-MzScheme/SIGNATURE
mzscheme/Language-MzScheme/lib/Language/MzScheme.pm
mzscheme/Language-MzScheme/lib/Language/MzScheme/Env.pm
mzscheme/Language-MzScheme/lib/Language/MzScheme/Object.pm
mzscheme/Language-MzScheme/mzscheme.c
mzscheme/Language-MzScheme/mzscheme.h
mzscheme/Language-MzScheme/mzscheme.i
mzscheme/Language-MzScheme/t/1-basic.t
Log:
----------------------------------------------------------------------
r5538 at not: autrijus | 2004-06-10T20:08:36.221579Z
* More warning avoidance.
* $vec->to_arrayref should be a bit more efficient now.
----------------------------------------------------------------------
r5539 at not: autrijus | 2004-06-11T17:20:00.422131Z
* checkpoint for context
----------------------------------------------------------------------
r5540 at not: autrijus | 2004-06-11T19:48:01.999479Z
* today's context work.
----------------------------------------------------------------------
r5541 at not: autrijus | 2004-06-12T11:12:49.074747Z
* in preparation for transparent dereferencing
----------------------------------------------------------------------
r5542 at not: autrijus | 2004-06-12T11:44:51.730294Z
* transparent callback for object and code references now work
* add both tests to MANIFEST.
----------------------------------------------------------------------
r5543 at not: autrijus | 2004-06-12T14:10:04.954036Z
* add $env->define_perl_wrappers to provide default perl bindings.
----------------------------------------------------------------------
r5544 at not: autrijus | 2004-06-12T16:00:20.599932Z
* New utility, script/mzperl, a perl-embedded mzscheme interpreter.
* ->as_perl_data now correctly dereferences perl-based primitives.
----------------------------------------------------------------------
r5545 at not: autrijus | 2004-06-12T17:12:53.807427Z
* beginning of roudtrip data structure support.
----------------------------------------------------------------------
r5546 at not: autrijus | 2004-06-12T17:33:12.257162Z
* Add new tests for context, object and data structures.
* Full round-trip for non-self-referential data structures now works.
----------------------------------------------------------------------
r5547 at not: autrijus | 2004-06-12T18:02:48.116183Z
* Add tests for calling into and from perl.
----------------------------------------------------------------------
r5548 at not: autrijus | 2004-06-12T18:48:45.471192Z
* Proper error handling; scheme-level errors are turned into "die" calls.
----------------------------------------------------------------------
r5549 at not: autrijus | 2004-06-12T19:14:21.460339Z
* Constrain object invocation arity to 1..+Inf instead of 0..+Inf.
----------------------------------------------------------------------
r5550 at not: autrijus | 2004-06-12T20:02:29.800146Z
* Finally implemented a sane error handling model.
* eval{} will return scheme_undefined; $SIG{__DIE__} can catch the actual error.
----------------------------------------------------------------------
Modified: mzscheme/Language-MzScheme/MANIFEST
==============================================================================
--- mzscheme/Language-MzScheme/MANIFEST (original)
+++ mzscheme/Language-MzScheme/MANIFEST Sun Jun 13 00:09:52 2004
@@ -5,6 +5,7 @@
inc/Module/Install/Fetch.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
+inc/Module/Install/Scripts.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
lib/Language/MzScheme.pm
@@ -18,6 +19,12 @@
mzscheme.h
mzscheme.i
README
+script/mzperl
SIGNATURE
t/0-signature.t
t/1-basic.t
+t/2-context.t
+t/3-object.t
+t/4-data.t
+t/5-perl.t
+t/6-error.t
Modified: mzscheme/Language-MzScheme/Makefile.PL
==============================================================================
--- mzscheme/Language-MzScheme/Makefile.PL (original)
+++ mzscheme/Language-MzScheme/Makefile.PL Sun Jun 13 00:09:52 2004
@@ -11,6 +11,7 @@
author('Autrijus Tang <autrijus at autrijus.org>');
license('perl');
build_requires('Test::More');
+install_script('script/mzperl');
can_cc() or die "This module requires a C compiler";
my ($swig_version) = (run('swig', '-version') =~ /([\d\.]+)/g)
Modified: mzscheme/Language-MzScheme/SIGNATURE
==============================================================================
--- mzscheme/Language-MzScheme/SIGNATURE (original)
+++ mzscheme/Language-MzScheme/SIGNATURE Sun Jun 13 00:09:52 2004
@@ -14,12 +14,12 @@
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
-SHA1 0c701f5d7c3c6bab57f7de26e62385e5954586b2 Changes
-SHA1 70dbdb5feee2565e7f4f43b0a650bc8b671a17a5 MANIFEST
+SHA1 f6c07f9fd0026e51000ac42e74bdf5baa35b87b0 Changes
+SHA1 725258b0ccfbff6678e6654269fe517b22113db9 MANIFEST
SHA1 7a81e2090d10fa9903f45f7255b4f30156eb0d5e MANIFEST.SKIP
-SHA1 364f7e6c2993851f9e31dec749d65efdf139c0c7 META.yml
-SHA1 a86f239a1d04a990d920f5a7361f9bb766fa020d Makefile.PL
-SHA1 c646116402a155a2692a5e45598b2bd0fe1635ac README
+SHA1 cde01e8ce89f28934db972e83e78b4918064e2ce META.yml
+SHA1 afb550250103699ef29fbb8655aa16746d32eac6 Makefile.PL
+SHA1 f502bcb5576b2678f411613940c5b901ba5f0270 README
SHA1 2b65fc08c268c16ae7097d800bacccc7b8c9c905 inc/Module/Install.pm
SHA1 fd56d5c793014bccac2cd1e61926c4da8538ef99 inc/Module/Install/Base.pm
SHA1 9ce6768a7b8f7032ec89594b773fafd58c6feb1d inc/Module/Install/Can.pm
@@ -28,16 +28,18 @@
SHA1 207dfa13341a374fc78325fbeb99bc36659aef2d inc/Module/Install/Metadata.pm
SHA1 aff9341a15c04faec47089851e43d9d4061337e7 inc/Module/Install/Win32.pm
SHA1 8e0d347ca21bc18b380d9d1aa5910b8d078a76b7 inc/Module/Install/WriteAll.pm
-SHA1 39b5fb63c4f704f5a4dcfd1f8a9f890f66f65eaa lib/Language/MzScheme.pm
-SHA1 0354b7c60461a0814fa55c80158b94bfcc0217c1 mzscheme.c
-SHA1 5e6d133835177fbe482176b8a4c6c9ea726ffd42 mzscheme.h
-SHA1 5f414bd7a8a73252da1529b628bb5ab2017f7e33 mzscheme.i
+SHA1 8972668427be2a5e60d605f6e7b2221bd473b177 lib/Language/MzScheme.pm
+SHA1 7e875019cf66fb5067f950303a04099e61013d15 lib/Language/MzScheme/Env.pm
+SHA1 1bd41bdd257036bdb498e1e994d46a0ee7a6bec7 lib/Language/MzScheme/Object.pm
+SHA1 94cc00555f421f82fec0c773cd78feada346efc9 mzscheme.c
+SHA1 037e4629663a8f49009c94ad07119e86a8167dfe mzscheme.h
+SHA1 f3380c2ca297a45f70f1c93765575f4f0fbc450c mzscheme.i
SHA1 63c7ea0cfdd7643aa113c260eec9c9bf0a6ee8a0 t/0-signature.t
-SHA1 9f5a47c2f80e621d3f081c7855b8c8f42a5d7178 t/1-basic.t
+SHA1 11073b71db07f6d25fadd1c8a521dd689fb9de45 t/1-basic.t
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.2.3 (FreeBSD)
-iD8DBQFAxk7EtLPdNzw1AaARApxOAKCv3XQZXxkmJmbs+hPUsuksEr7z5QCgsYIx
-sAGZwKSEc+AxmQx7JJbAj2Q=
-=cu6X
+iD8DBQFAyLgmtLPdNzw1AaARAvsRAJsGxPXslfOizm0fQyYSF1bC5EBa7gCeJXmb
+FhUWxyMewuNedJVKfy6vjqQ=
+=JhaR
-----END PGP SIGNATURE-----
Modified: mzscheme/Language-MzScheme/lib/Language/MzScheme.pm
==============================================================================
--- mzscheme/Language-MzScheme/lib/Language/MzScheme.pm (original)
+++ mzscheme/Language-MzScheme/lib/Language/MzScheme.pm Sun Jun 13 00:09:52 2004
@@ -24,43 +24,51 @@
=head1 SYNOPSIS
- use strict;
use Language::MzScheme;
- my $env = Language::MzScheme->basic_env;
- my $val = $env->eval('(+ 1 2)');
+ my $env = Language::MzScheme->new;
+ my $obj = $env->eval('(+ 1 2)');
- # See t/1-basic.t in the source distribution for more!
+ # See t/*.t in the source distribution for more!
=head1 DESCRIPTION
This module provides Perl bindings to PLT's MzScheme language.
-The documentation is sorely lacking at this moment. Please consult
-F<t/1-basic.t> in the source distribution, for a synopsis of supported
-features.
+The documentation is sorely lacking at this moment. For an overview of
+supported features, please consult F<t/*.t> in the source distribution.
=cut
+sub new {
+ my $self = shift;
+ my $env = $self->basic_env;
+ $env->define_perl_wrappers;
+ return $env;
+}
+
if (!$Language::MzScheme::Initialized) {
- mzscheme_init() if defined &mzscheme_init;
+ no strict 'refs';
+ if (defined &mzscheme_init) {
+ mzscheme_init();
+ $Language::MzScheme::scheme_case_sensitive = 1;
+ }
foreach my $func (@EXPORT_OK) {
- no strict 'refs';
my $idx = index(lc($func), 'scheme_');
$idx > -1 or next;
my $sym = substr($func, $idx + 7);
- *$sym = sub { shift; goto &$func } unless defined &$sym;
+ *$sym = sub { shift; goto &$func }
+ unless defined &$sym or defined $$sym;
}
foreach my $func (@EXPORT_OK) {
- no strict 'refs';
- my $idx = index(lc($func), 'scheme_');
+ my $idx = index(lc($func), 'mzscheme_');
$idx > -1 or next;
- my $sym = substr($func, $idx + 7);
- *$sym = sub { shift; goto &$func } unless defined &$sym;
+ my $sym = substr($func, $idx + 9);
+ *$sym = sub { shift; goto &$func }
+ unless defined &$sym or defined $$sym;
}
- *VERSION = \&UNIVERSAL::VERSION;
$Language::MzScheme::Initialized++;
}
Modified: mzscheme/Language-MzScheme/lib/Language/MzScheme/Env.pm
==============================================================================
--- mzscheme/Language-MzScheme/lib/Language/MzScheme/Env.pm (original)
+++ mzscheme/Language-MzScheme/lib/Language/MzScheme/Env.pm Sun Jun 13 00:09:52 2004
@@ -5,38 +5,57 @@
use strict;
use constant S => "Language::MzScheme";
+foreach my $sym (qw(
+ perl_do perl_eval perl_require perl_use perl_no
+)) {
+ no strict 'refs';
+ my $proc = $sym;
+ $proc =~ tr/_/-/;
+ *$sym = sub {
+ my $self = shift;
+ $self->apply($proc, @_);
+ };
+}
+
sub eval {
my $self = shift;
my $obj = UNIVERSAL::isa($_[0], S."::Object")
- ? S->eval($_[0], $self)
- : S->eval_string_all($_[0], $self, 1);
- $Objects{+$obj} ||= $self if ref($obj);
+ ? S->do_eval($_[0], $self)
+ : S->do_eval_string_all($_[0], $self, 1);
+ $Objects{S->REFADDR($obj)} ||= $self if ref($obj);
return $obj;
}
sub define {
- my ($self, $name, $code) = @_;
- my $obj = $self->lambda($code);
+ my ($self, $name, $code, $sigil) = @_;
+
+ $code ||= $name;
+ $sigil ||= substr($name, -1) if $name =~ /['!?\@\$\%]$/;
+
+ my $obj = $self->lambda($code, $sigil);
+
S->add_global($name, $obj, $self);
return $self->lookup($name);
}
sub lambda {
- my ($self, $code) = @_;
+ my ($self, $code, $sigil) = @_;
+ my $name = "$code";
+ $name .= ":$sigil" if $sigil;
+
my $obj = UNIVERSAL::isa($code, 'CODE')
- ? S->make_perl_prim_w_arity($code, "$code", 0, -1)
- : S->make_perl_object_w_arity($code, "$code", 0, -1);
- $Objects{+$obj} ||= $self;
+ ? S->make_perl_prim_w_arity($code, "$name", 0, -1, $sigil)
+ : S->make_perl_object_w_arity($code, "$name", 1, -1, $sigil);
+
+ $Objects{S->REFADDR($obj)} ||= $self;
return $obj;
}
sub apply {
my ($self, $name) = splice(@_, 0, 2);
@_ = map S->from_perl_scalar($_), @_;
- my $obj = S->apply($self->lookup($name), 0+ at _, \@_);
-# return @$obj if wantarray and $obj->isa('ARRAY');
-# return %$obj if wantarray and $obj->isa('HASH');
- $Objects{+$obj} ||= $self if ref($obj);
+ my $obj = S->do_apply($self->lookup($name), 0+ at _, \@_);
+ $Objects{S->REFADDR($obj)} ||= $self if ref($obj);
return $obj;
}
@@ -47,8 +66,51 @@
my $sym = S->intern_symbol($name);
my $obj = S->lookup_global($sym, $self);
- $Objects{+$obj} ||= $self;
+ $Objects{S->REFADDR($obj)} ||= $self;
return $obj;
}
+sub define_perl_wrappers {
+ my $self = shift;
+ my $require = sub { $self->_wrap_require(@_) };
+ $self->define('perl-do', sub { do $_[0] });
+ $self->define('perl-eval', sub { eval "@_" });
+ $self->define('perl-no', $require); # XXX unimport
+ $self->define('perl-use', sub {
+ no strict 'refs';
+ my $pkg = $require->(@_); shift;
+
+ # XXX - should export using a fake package instead
+ @_ = @{"$pkg\::EXPORT"} if !@_ and UNIVERSAL::isa($pkg, 'Exporter');
+
+ foreach my $sym (map { $_->isa('ARRAY') ? @$_ : $_ } @_) {
+ my $code = $pkg->can($sym) or next;
+ $self->define($sym, $code);
+ }
+
+ foreach my $sym (sort keys %{"$pkg\::"}) {
+ my $code = *{${"$pkg\::"}{$sym}}{CODE} or next;
+ $sym =~ tr/_/-/;
+ $self->define("$pkg\::$sym", $code);
+ $self->define($sym, $code);
+ }
+
+ return $pkg;
+ });
+ $self->define('perl-require', $require);
+ # XXX current-command-line-arguments
+}
+
+sub _wrap_require {
+ my $self = shift;
+ my $pkg = shift;
+ $pkg =~ s{::}{/}g;
+ $pkg .= ".pm" if index($pkg, '.') == -1;
+ require $pkg;
+ $pkg =~ s{/}{::}g;
+ $pkg =~ s{\.pm$}{}i;
+ $self->define($pkg);
+ return $pkg;
+}
+
1;
Modified: mzscheme/Language-MzScheme/lib/Language/MzScheme/Object.pm
==============================================================================
--- mzscheme/Language-MzScheme/lib/Language/MzScheme/Object.pm (original)
+++ mzscheme/Language-MzScheme/lib/Language/MzScheme/Object.pm Sun Jun 13 00:09:52 2004
@@ -8,7 +8,7 @@
'bool' => \&to_bool,
'""' => \&to_string,
'0+' => \&to_number,
- '=' => \&to_lvalue,
+ '!' => \&to_negate,
'&{}' => \&to_coderef,
'%{}' => \&to_hashref,
'@{}' => \&to_arrayref,
@@ -37,7 +37,10 @@
*$sym = sub { $_[0]->apply($proc, $_[0]) };
}
-foreach my $proc (qw( eval apply lambda lookup )) {
+foreach my $proc (qw(
+ eval apply lambda lookup
+ perl_do perl_eval perl_require perl_use perl_no
+)) {
no strict 'refs';
*$proc = sub {
my $env = shift(@_)->env;
@@ -47,35 +50,37 @@
sub to_bool {
my $self = shift;
- !(S->VOIDP($self) || S->FALSEP($self));
+ !S->UNDEFP($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) ? '' :
+ S->UNDEFP($self) ? '' :
$self->as_display;
}
sub to_number {
my $self = shift;
- S->VOIDP($self) ? undef :
- S->FALSEP($self) ? 0 :
- $self->as_display;
+ S->UNDEFP($self) ? 0 : $self->as_display;
+}
+
+sub to_negate {
+ my $self = shift;
+ S->UNDEFP($self) ? '#t' : undef;
}
sub env {
my $self = shift;
- $Language::MzScheme::Env::Objects{+$self}
+ $Language::MzScheme::Env::Objects{S->REFADDR($self)}
or die "Cannot find associated environment";
}
sub bless {
my ($self, $obj) = @_;
- $Language::MzScheme::Env::Objects{+$obj}||=
- $Language::MzScheme::Env::Objects{+$self};
+ $Language::MzScheme::Env::Objects{S->REFADDR($obj)}||=
+ $Language::MzScheme::Env::Objects{S->REFADDR($self)} if defined $obj;
return $obj;
}
@@ -95,7 +100,7 @@
$self,
$Cons ||= $self->lookup('cons'),
) : $self;
-
+
my %rv;
while (my $obj = $alist->car) {
$rv{$obj->car} = $obj->cdr;
@@ -108,7 +113,10 @@
my $self = shift;
if (S->VECTORP($self)) {
- return [ map $self->bless($_), @{S->VEC_BASE($self)} ];
+ my $vec = S->VEC_BASE($self);
+ my $env = $self->env;
+ $Language::MzScheme::Env::Objects{+$_}||=$env for @$vec;
+ return $vec;
}
return [
@@ -139,23 +147,29 @@
sub as_perl_data {
my $self = shift;
- if ( $self->isa('CODE') ) {
+ if ( S->PERLP($self) ) {
+ return S->to_perl_scalar($self);
+ }
+ if ( S->CODE_REFP($self) ) {
return $self->to_coderef;
}
- elsif ( $self->isa('HASH') and !S->NULLP($self) ) {
+ elsif ( S->HASHTP($self) ) {
my $hash = $self->to_hashref;
$hash->{$_} = $hash->{$_}->as_perl_data for keys %$hash;
return $hash;
}
- elsif ( $self->isa('ARRAY') ) {
+ elsif ( S->ARRAY_REFP($self) ) {
return [ map $_->as_perl_data, @{$self->to_arrayref} ];
}
- elsif ( $self->isa('GLOB') ) {
+ elsif ( S->GLOB_REFP($self) ) {
return $self; # XXX -- doesn't really know what to do
}
- elsif ( $self->isa('SCALAR') ) {
+ elsif ( S->SCALAR_REFP($self) ) {
return \${$self->to_scalarref}->as_perl_data;
}
+ elsif ( S->UNDEFP($self) ) {
+ return undef;
+ }
else {
$self->to_string;
}
@@ -163,23 +177,8 @@
sub isa {
my ($self, $type) = @_;
- ($type eq 'CODE') ? S->PROCP($self) :
- ($type eq 'HASH') ? S->HASHTP($self) || $self->is_alist :
- ($type eq 'ARRAY') ? S->LISTP($self) || S->VECTORP($self) :
- ($type eq 'GLOB') ? S->INPORTP($self) || S->OUTPORTP($self) :
- ($type eq 'SCALAR') ? S->BOXP($self) :
- $self->SUPER::isa($type);
-}
-
-sub is_alist {
- my $self = shift;
- S->NULLP($self) || (
- S->PAIRP($self) &&
- S->PAIRP($self->car) &&
- !S->LISTP($self->caar) &&
- (!S->PAIRP($self->car->cdr) || S->NULLP($self->car->cdr->cdr)) &&
- $self->cdr->is_alist
- );
+ my $p = S->can("MZSCHEME_${type}_REFP") or return $self->SUPER::isa($type);
+ return $p->($self);
}
1;
Modified: mzscheme/Language-MzScheme/mzscheme.c
==============================================================================
--- mzscheme/Language-MzScheme/mzscheme.c (original)
+++ mzscheme/Language-MzScheme/mzscheme.c Sun Jun 13 00:09:52 2004
@@ -8,24 +8,61 @@
}
Scheme_Object *
-mzscheme_make_perl_prim_w_arity (Perl_Scalar cv_ref, const char *name, int mina, int maxa) {
- SvREFCNT_inc((SV *)cv_ref);
+mzscheme_make_perl_prim_w_arity (Perl_Scalar cv_ref, const char *name, int mina, int maxa, const char *sigil_string) {
+ Perl_Callback *callback = (Perl_Callback *)malloc(sizeof(Perl_Callback));
+ callback->magic = Perl_Callback_MAGIC;
+ callback->sv = cv_ref;
+ callback->sigil = ((sigil_string == NULL) ? NULL : *sigil_string);
+ SvREFCNT_inc(cv_ref);
+
return scheme_make_closed_prim_w_arity(
&_mzscheme_closed_prim_CV,
- (void *)cv_ref, name, mina, maxa
+ (void *)callback, savepv(name), mina, maxa
);
}
Scheme_Object *
-mzscheme_make_perl_object_w_arity (Perl_Scalar object, const char *name, int mina, int maxa) {
- SvREFCNT_inc((SV *)object);
+mzscheme_make_perl_object_w_arity (Perl_Scalar object, const char *name, int mina, int maxa, const char *sigil_string) {
+ Perl_Callback *callback = (Perl_Callback *)malloc(sizeof(Perl_Callback));
+ callback->magic = Perl_Callback_MAGIC;
+ callback->sv = object;
+ callback->sigil = ((sigil_string == NULL) ? NULL : *sigil_string);
+ SvREFCNT_inc(object);
+
return scheme_make_closed_prim_w_arity(
&_mzscheme_closed_prim_OBJ,
- (void *)object, name, mina, maxa
+ (void *)callback, savepv(name), mina, maxa
);
}
Scheme_Object *
+mzscheme_from_perl_arrayref (Perl_Scalar sv) {
+ return scheme_build_list(
+ 1+(int)av_len( (AV*)SvRV(sv) ),
+ _mzscheme_from_perl_arrayref_to_objects(sv)
+ );
+}
+
+Scheme_Object *
+mzscheme_from_perl_hashref (Perl_Scalar sv) {
+ HV* hv = (HV*)SvRV(sv);
+ HE* entry;
+ I32 retlen;
+ Scheme_Hash_Table *hash = scheme_make_hash_table(SCHEME_hash_ptr);
+
+ (void)hv_iterinit(hv);
+ while ((entry = hv_iternext(hv))) {
+ scheme_hash_set(
+ hash,
+ scheme_intern_symbol( hv_iterkey(entry, &retlen) ),
+ mzscheme_from_perl_scalar( hv_iterval(hv, entry) )
+ );
+ }
+
+ return (Scheme_Object *)hash;
+}
+
+Scheme_Object *
mzscheme_from_perl_scalar (Perl_Scalar sv) {
Scheme_Object *temp;
@@ -33,17 +70,63 @@
SvROK(sv) ?
(SWIG_ConvertPtr(sv, (void **) &temp, SWIGTYPE_p_Scheme_Object, 0) >= 0)
? temp :
- sv_isobject(SvRV(sv))
- ? mzscheme_make_perl_object_w_arity((Perl_Scalar)SvRV(sv), SvPV(sv, PL_na), 0, -1) :
+ sv_isobject(sv)
+ ? mzscheme_make_perl_object_w_arity(
+ sv, Perl_form(aTHX_ "REF(0x%"UVxf")", PTR2UV(SvRV(sv))), 1, -1, NULL
+ ) :
(SvTYPE(SvRV(sv)) == SVt_PVCV)
- ? mzscheme_make_perl_prim_w_arity((Perl_Scalar)SvRV(sv), SvPV(sv, PL_na), 0, -1)
- : scheme_void :
+ ? mzscheme_make_perl_prim_w_arity(sv, SvPV(sv, PL_na), 0, -1, NULL) :
+ (SvTYPE(SvRV(sv)) == SVt_PVAV)
+ ? mzscheme_from_perl_arrayref(sv) :
+ (SvTYPE(SvRV(sv)) == SVt_PVHV)
+ ? mzscheme_from_perl_hashref(sv) :
+ scheme_box(mzscheme_from_perl_scalar((Perl_Scalar)SvRV(sv)))
+ :
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) ) : scheme_void
);
}
+Scheme_Object *
+mzscheme_from_perl_symbol (Perl_Scalar sv) {
+ Scheme_Object *temp;
+
+ /* XXX - eventually rewrite the symbol logic from ROK */
+ return (
+ SvROK(sv) ?
+ (SWIG_ConvertPtr(sv, (void **) &temp, SWIGTYPE_p_Scheme_Object, 0) >= 0)
+ ? temp :
+ sv_isobject(sv)
+ ? mzscheme_make_perl_object_w_arity(
+ sv, Perl_form(aTHX_ "REF(0x%"UVxf")", PTR2UV(SvRV(sv))), 1, -1, NULL
+ ) :
+ (SvTYPE(SvRV(sv)) == SVt_PVCV)
+ ? mzscheme_make_perl_prim_w_arity(sv, SvPV(sv, PL_na), 0, -1, NULL) :
+ (SvTYPE(SvRV(sv)) == SVt_PVAV)
+ ? mzscheme_from_perl_arrayref(sv) :
+ (SvTYPE(SvRV(sv)) == SVt_PVHV)
+ ? mzscheme_from_perl_hashref(sv) :
+ scheme_box(mzscheme_from_perl_scalar((Perl_Scalar)SvRV(sv)))
+ :
+ SvIOK(sv) ? scheme_make_integer_value( (int)SvIV(sv) ) :
+ SvNOK(sv) ? scheme_make_double( (double)SvNV(sv) ) :
+ SvPOK(sv) ? scheme_intern_symbol( (char *)SvPV(sv, PL_na) ) : scheme_void
+ );
+}
+
+Perl_Scalar
+mzscheme_to_perl_scalar (Scheme_Object *obj) {
+ if (MZSCHEME_PERLP(obj)) {
+ return ((Perl_Callback *)SCHEME_CLSD_PRIM_DATA(obj))->sv;
+ }
+ else {
+ Perl_Scalar sv = sv_newmortal();
+ SWIG_MakePtr(sv, (void *)obj, SWIGTYPE_p_Scheme_Object, 0);
+ return sv;
+ }
+}
+
void
_mzscheme_enter (int argc, Scheme_Object **argv) {
dSP ;
@@ -56,9 +139,7 @@
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);
+ PUSHs(mzscheme_to_perl_scalar(argv[i]));
}
PUTBACK ;
@@ -78,51 +159,113 @@
PUSHs(sv);
for (i = 1; i < argc; i++) {
- SV *sv = sv_newmortal();
- SWIG_MakePtr(sv, (void *)argv[i], SWIGTYPE_p_Scheme_Object, 0);
- PUSHs(sv);
+ PUSHs(mzscheme_to_perl_scalar(argv[i]));
}
PUTBACK ;
}
Scheme_Object *
-_mzscheme_leave (int count) {
- dSP ;
+_mzscheme_leave (int count, char sigil) {
+ dSP;
+ Scheme_Object *rv = NULL;
Scheme_Object **return_values;
int i;
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);
+ if (sigil == NULL) {
+ /* Auto-context */
+ sigil = ((count == 1) ? Perl_Context_SCALAR : Perl_Context_LIST);
+ }
+
+ switch (sigil) {
+ case Perl_Context_BOOLEAN :
+ rv = (((count > 0) && SvTRUE(TOPs)) ? scheme_true : scheme_false);
+ break;
+ case Perl_Context_SYMBOL :
+ rv = ((count > 0) ? mzscheme_from_perl_symbol(TOPs) : scheme_null);
+ break;
+ case Perl_Context_SCALAR :
+ rv = ((count > 0) ? mzscheme_from_perl_scalar(TOPs) : scheme_null);
+ break;
+ case Perl_Context_VOID :
+ rv = scheme_void;
+ break;
+ case Perl_Context_HASH : {
+ Scheme_Hash_Table *hash = scheme_make_hash_table(SCHEME_hash_ptr);
+ if ((count % 2) == 1) {
+ scheme_hash_set(
+ hash,
+ mzscheme_from_perl_symbol(POPs),
+ scheme_void
+ );
+ count--;
+ }
+ for (i = 0; i < count ; i+=2) {
+ rv = mzscheme_from_perl_symbol(POPs);
+ scheme_hash_set(
+ hash,
+ mzscheme_from_perl_symbol(POPs),
+ rv
+ );
+ }
+ rv = (Scheme_Object *)hash;
+ } break;
+ default: /* ARRAY */
+ if (count == 0) {
+ rv = scheme_null;
+ }
+ else {
+ 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);
+ }
+ }
+ rv = scheme_build_list((int)count, return_values);
}
PUTBACK ;
FREETMPS ;
LEAVE ;
- return scheme_build_list((int)count, return_values);
+ return rv;
}
Scheme_Object *
_mzscheme_closed_prim_CV (void *callback, int argc, Scheme_Object **argv) {
+ char sigil = ((Perl_Callback *)callback)->sigil;
+
_mzscheme_enter(argc, argv);
- return _mzscheme_leave( (int)call_sv((SV*)callback, G_ARRAY) );
+ return _mzscheme_leave(
+ (int)call_sv( ((Perl_Callback *)callback)->sv, Perl_Context(sigil) ),
+ sigil
+ );
}
Scheme_Object *
_mzscheme_closed_prim_OBJ (void *callback, int argc, Scheme_Object **argv) {
- const char *method;
+ char sigil = ((Perl_Callback *)callback)->sigil;
+ char *method;
if (argc == 0) {
return scheme_undefined;
}
- method = SCHEME_STRSYM_VAL(argv[0]);
- _mzscheme_enter_with_sv((SV *)callback, argc, argv);
- return _mzscheme_leave( (int)call_method(method, G_ARRAY) );
+ method = savepv(SCHEME_STRSYM_VAL(argv[0]));
+ if (sigil == NULL) {
+ char *i = method;
+ while (*i) { i++; }
+ if (ispunct(*--i)) {
+ sigil = *i;
+ *i = NULL;
+ }
+ }
+ _mzscheme_enter_with_sv(((Perl_Callback *)callback)->sv, argc, argv);
+ return _mzscheme_leave(
+ (int)call_method( method, Perl_Context(sigil) ),
+ sigil
+ );
}
AV *
@@ -135,10 +278,57 @@
};
svs = (SV **)malloc(len*sizeof(SV *));
for (i = 0; i < len ; i++) {
- svs[i] = sv_newmortal();
- SWIG_MakePtr(svs[i], (void *)objects[i], SWIGTYPE_p_Scheme_Object, 0);
+ svs[i] = mzscheme_to_perl_scalar(objects[i]);
};
myav = av_make(len, svs);
free(svs);
return myav;
}
+
+int
+_mzscheme_alistp (Scheme_Object *object) {
+ return (SCHEME_NULLP(object) || (
+ SCHEME_PAIRP(object) &&
+ SCHEME_PAIRP(SCHEME_CAR(object)) &&
+ !SCHEME_LISTP(SCHEME_CAAR(object)) && (
+ (!SCHEME_PAIRP(SCHEME_CDR(SCHEME_CAR(object)))) ||
+ SCHEME_NULLP(SCHEME_CDDR(SCHEME_CAR(object)))
+ ) &&
+ _mzscheme_alistp(SCHEME_CDR(object))
+ ));
+}
+
+Scheme_Object **
+_mzscheme_from_perl_arrayref_to_objects (Perl_Scalar sv) {
+ Scheme_Object **rv;
+ AV *tempav;
+ I32 len;
+ int i;
+ SV **tv;
+
+ tempav = (AV*)SvRV(sv);
+ len = av_len(tempav);
+ rv = malloc((len+2)*sizeof(Scheme_Object *));
+
+ for (i = 0; i <= len; i++) {
+ tv = av_fetch(tempav, i, 0);
+ rv[i] = mzscheme_from_perl_scalar(*tv);
+ }
+ rv[i] = NULL;
+ return rv;
+}
+
+Scheme_Object *
+mzscheme_do_apply (Scheme_Object *f, int c, Scheme_Object **args) {
+ MZSCHEME_DO( scheme_apply(f, c, args) );
+}
+
+Scheme_Object *
+mzscheme_do_eval (Scheme_Object *expr, Scheme_Env *env) {
+ MZSCHEME_DO( scheme_eval(expr, env) );
+}
+
+Scheme_Object *
+mzscheme_do_eval_string_all (char *str, Scheme_Env *env, int all) {
+ MZSCHEME_DO( scheme_eval_string_all(str, env, all) );
+}
Modified: mzscheme/Language-MzScheme/mzscheme.h
==============================================================================
--- mzscheme/Language-MzScheme/mzscheme.h (original)
+++ mzscheme/Language-MzScheme/mzscheme.h Sun Jun 13 00:09:52 2004
@@ -1,5 +1,61 @@
typedef SV* Perl_Scalar;
+typedef struct {
+ int magic;
+ Perl_Scalar sv;
+ char sigil;
+} Perl_Callback;
+
+Scheme_Object* mzscheme_from_perl_scalar (Perl_Scalar sv);
+
AV* _mzscheme_objects_AV (void **objects, char *type);
Scheme_Object* _mzscheme_closed_prim_CV (void *d, int argc, Scheme_Object **argv);
-Scheme_Object * _mzscheme_closed_prim_OBJ (void *callback, int argc, Scheme_Object **argv);
+Scheme_Object* _mzscheme_closed_prim_OBJ (void *callback, int argc, Scheme_Object **argv);
+Scheme_Object** _mzscheme_from_perl_arrayref_to_objects (Perl_Scalar sv);
+
+#define Perl_Callback_MAGIC '&'
+#define Perl_Context_BOOLEAN '?'
+#define Perl_Context_SCALAR '$'
+#define Perl_Context_SYMBOL '\''
+#define Perl_Context_LIST '@'
+#define Perl_Context_HASH '%'
+#define Perl_Context_VOID '!'
+#define Perl_Context(sigil) \
+ ( (sigil == Perl_Context_VOID) ? G_VOID : \
+ ((sigil == Perl_Context_BOOLEAN) || \
+ (sigil == Perl_Context_SCALAR) || \
+ (sigil == Perl_Context_SYMBOL)) ? G_SCALAR : \
+ G_ARRAY )
+
+#define MZSCHEME_REFADDR(sv) (SvROK(sv) ? (int)PTR2UV(SvRV(sv)) : 0)
+#define MZSCHEME_UNDEFP(obj) SAME_OBJ((obj), scheme_void) || \
+ SAME_OBJ((obj), scheme_undefined) || \
+ SAME_OBJ((obj), scheme_false) || \
+ SAME_OBJ((obj), scheme_eof)
+#define MZSCHEME_ALISTP(obj) _mzscheme_alistp(obj)
+
+#define MZSCHEME_CODE_REFP(obj) SCHEME_PROCP(obj)
+#define MZSCHEME_HASH_REFP(obj) SCHEME_HASHTP(obj) || MZSCHEME_ALISTP(obj)
+#define MZSCHEME_ARRAY_REFP(obj) SCHEME_LISTP(obj) || SCHEME_VECTORP(obj)
+#define MZSCHEME_GLOB_REFP(obj) SCHEME_INPORTP(obj) || SCHEME_OUTPORTP(obj)
+#define MZSCHEME_SCALAR_REFP(obj) SCHEME_BOXP(obj)
+
+#define MZSCHEME_PERLP(obj) (SCHEME_CLSD_PRIMP(obj) && \
+ ((Perl_Callback *)SCHEME_CLSD_PRIM_DATA(obj))->magic == Perl_Callback_MAGIC)
+
+#define MZSCHEME_DO(expr) \
+ Scheme_Object *port = scheme_make_string_output_port(); \
+ scheme_set_param(scheme_config, MZCONFIG_ERROR_PORT, port); \
+ if (scheme_setjmp(scheme_error_buf)) { \
+ if (PL_in_eval) { \
+ sv_setpv(ERRSV, scheme_get_string_output(port)); \
+ return scheme_undefined; \
+ } \
+ else { \
+ croak("%s", scheme_get_string_output(port)); \
+ } \
+ } \
+ else { \
+ return expr; \
+ }
+
Modified: mzscheme/Language-MzScheme/mzscheme.i
==============================================================================
--- mzscheme/Language-MzScheme/mzscheme.i (original)
+++ mzscheme/Language-MzScheme/mzscheme.i Sun Jun 13 00:09:52 2004
@@ -9,26 +9,13 @@
}
%typemap(out) Perl_Scalar {
- $result = (SV *)$1;
+ $result = newSVsv((SV *)$1);
+ sv_2mortal($result);
+ argvi++;
}
%typemap(in) Scheme_Object ** {
- AV *tempav;
- I32 len;
- int i;
- SV **tv;
- if (!SvROK($input))
- croak("argument $argnum is not a reference.");
- if (SvTYPE(SvRV($input)) != SVt_PVAV)
- croak("argument $argnum is not an array.");
- tempav = (AV*)SvRV($input);
- len = av_len(tempav);
- $1 = (Scheme_Object **) malloc((len+2)*sizeof(Scheme_Object *));
- for (i = 0; i <= len; i++) {
- tv = av_fetch(tempav, i, 0);
- SWIG_ConvertPtr((SV *)*tv, (void **) &$1[i], SWIGTYPE_p_Scheme_Object, 0);
- }
- $1[i] = NULL;
+ $1 = _mzscheme_from_perl_arrayref_to_objects($input);
};
%typemap(freearg) Scheme_Object ** {
@@ -42,9 +29,27 @@
}
void mzscheme_init();
-Scheme_Object* mzscheme_make_perl_prim_w_arity(Perl_Scalar cv_ref, const char *name, int mina, int maxa);
-Scheme_Object* mzscheme_make_perl_object_w_arity(Perl_Scalar object, const char *name, int mina, int maxa);
+Scheme_Object* mzscheme_make_perl_prim_w_arity(Perl_Scalar cv_ref, const char *name, int mina, int maxa, const char *sigil);
+Scheme_Object* mzscheme_make_perl_object_w_arity(Perl_Scalar object, const char *name, int mina, int maxa, const char *sigil);
Scheme_Object * mzscheme_from_perl_scalar (Perl_Scalar sv);
+Scheme_Object * mzscheme_from_perl_symbol (Perl_Scalar sv);
+Scheme_Object * mzscheme_from_perl_arrayref (Perl_Scalar sv);
+Scheme_Object * mzscheme_from_perl_hashref (Perl_Scalar sv);
+Perl_Scalar mzscheme_to_perl_scalar (Scheme_Object *obj);
+
+Scheme_Object * mzscheme_do_apply(Scheme_Object *f, int c, Scheme_Object **args);
+Scheme_Object * mzscheme_do_eval(Scheme_Object *expr, Scheme_Env *env);
+Scheme_Object * mzscheme_do_eval_string_all(char *str, Scheme_Env *env, int all);
+
+int MZSCHEME_REFADDR(Perl_Scalar sv);
+int MZSCHEME_UNDEFP(Scheme_Object *obj);
+int MZSCHEME_ALISTP(Scheme_Object *obj);
+int MZSCHEME_CODE_REFP(Scheme_Object *obj);
+int MZSCHEME_HASH_REFP(Scheme_Object *obj);
+int MZSCHEME_ARRAY_REFP(Scheme_Object *obj);
+int MZSCHEME_GLOB_REFP(Scheme_Object *obj);
+int MZSCHEME_SCALAR_REFP(Scheme_Object *obj);
+int MZSCHEME_PERLP(Scheme_Object *obj);
Scheme_Type SCHEME_TYPE(Scheme_Object *obj);
int SCHEME_PROCP(Scheme_Object *obj);
@@ -128,6 +133,7 @@
#define SCHEME_CPTR_VAL(obj) SCHEME_PTR1_VAL(obj)
#define SCHEME_CPTR_TYPE(obj) ((char *)SCHEME_PTR2_VAL(obj))
+int scheme_case_sensitive;
Scheme_Config *scheme_config;
Scheme_Env *scheme_basic_env(void);
Added: mzscheme/Language-MzScheme/script/mzperl
==============================================================================
--- (empty file)
+++ mzscheme/Language-MzScheme/script/mzperl Sun Jun 13 00:09:52 2004
@@ -0,0 +1,6 @@
+#!/usr/bin/perl
+use Language::MzScheme;
+my $env = Language::MzScheme->new;
+my $file = (@ARGV ? shift(@ARGV) : '-');
+open CODE, $file or die qq(Can't open mzperl script "$file": $!\n);
+$env->eval(do { local $/; my $code = <CODE>; $code =~ s{^#!.*}{}; $code });
Modified: mzscheme/Language-MzScheme/t/1-basic.t
==============================================================================
--- mzscheme/Language-MzScheme/t/1-basic.t (original)
+++ mzscheme/Language-MzScheme/t/1-basic.t Sun Jun 13 00:09:52 2004
@@ -1,11 +1,11 @@
#!/usr/bin/perl
use strict;
-use Test::More 'no_plan';
+use Test::More tests => 32;
use_ok('Language::MzScheme');
-my $env = Language::MzScheme->basic_env;
+my $env = Language::MzScheme->new;
my $obj = $env->eval(q{
(- 1 1)
});
@@ -52,7 +52,7 @@
isa_ok($code, 'CODE', 'to_coderef');
is($code->(4), 16, '->(), scheme-lambda');
-my $lambda = sub { (Hello => map $_, reverse @_) };
+my $lambda = sub { (Hello => reverse @_) };
my $hello = $env->define('perl-hello', $lambda);
isa_ok($hello, 'CODE', 'define');
@@ -72,13 +72,3 @@
is($hello->("Scheme", "Perl")->caddr, 'Scheme', '->caddr');
is($env->eval('(caddr (perl-hello "Scheme" "Perl"))'), 'Scheme', $ditto);
-require Math::BigInt;
-my $bigint = $env->define('bigint', Math::BigInt->new(0x12345));
-ok(eq_array($bigint->('as_hex'), ['0x12345']), '->(), perl-object');
-ok(eq_array($env->eval("(bigint 'as_hex)"), ['0x12345']), $ditto);
-
-$env->define('perl-eval-list', sub { eval $_[0] });
-$env->eval('(define (perl-eval x) (car (perl-eval-list x)))');
-is(eval($env->eval(q{(perl-eval "$env->eval('(perl-eval 1729)')")})), 1729, 'nested eval');
-
-1;
Added: mzscheme/Language-MzScheme/t/2-context.t
==============================================================================
--- (empty file)
+++ mzscheme/Language-MzScheme/t/2-context.t Sun Jun 13 00:09:52 2004
@@ -0,0 +1,88 @@
+#!/usr/bin/perl
+
+use strict;
+use Data::Dumper;
+use Test::More tests => 43;
+
+use_ok('Language::MzScheme');
+
+my $env = Language::MzScheme->new;
+
+my $sigils = {
+ auto => '',
+ bool => '?',
+ void => '!',
+ list => '@',
+ hash => '%',
+ scalar => '$',
+ symbol => '\'',
+};
+
+my $plans = [
+ sub { @_ } => [
+ [] => {
+ auto => [], void => undef,
+ bool => undef, list => [],
+ scalar => 0, symbol => 0,
+ hash => {},
+ },
+ [2] => {
+ auto => 2, void => undef,
+ bool => '#t', list => [2],
+ scalar => 1, symbol => 1,
+ hash => { 2 => undef },
+ },
+ [1,2] => {
+ auto => [1,2], void => undef,
+ bool => '#t', list => [1,2],
+ scalar => 2, symbol => 2,
+ hash => { 1 => 2 },
+ },
+ ["a","b"] => {
+ auto => ["a","b"],void => undef,
+ bool => '#t', list => ["a","b"],
+ scalar => 2, symbol => 2,
+ hash => { a => "b" },
+ },
+ ],
+ sub { 0 } => [
+ [] => {
+ auto => 0, void => undef,
+ bool => undef, list => [0],
+ scalar => 0, symbol => 0,
+ hash => { 0 => undef },
+ },
+ ],
+ sub { "a", "b" } => [
+ [] => {
+ auto => ["a","b"],void => undef,
+ bool => '#t', list => ["a","b"],
+ scalar => "b", symbol => "b",
+ hash => {"a","b"},
+ },
+ ],
+];
+
+my ($sub, $plan);
+my $subs = {
+ map {
+ ($_ => $env->define('perl-list'.$sigils->{$_}, sub { goto &$sub })),
+ } keys %$sigils
+};
+
+$Data::Dumper::Terse = 1;
+$Data::Dumper::Indent = 0;
+$Data::Dumper::Quotekeys = 0;
+while (($sub, $plan) = splice(@$plans, 0, 2)) {
+ while (my ($input, $output) = splice(@$plan, 0, 2)) {
+ foreach my $context (sort keys %$output) {
+ my $out = Dumper($output->{$context});
+ chomp $out;
+ is_deeply(
+ $subs->{$context}->(@$input)->as_perl_data,
+ $output->{$context},
+ "$context context, input: (@$input), output: $out"
+ );
+ }
+ }
+}
Added: mzscheme/Language-MzScheme/t/3-object.t
==============================================================================
--- (empty file)
+++ mzscheme/Language-MzScheme/t/3-object.t Sun Jun 13 00:09:52 2004
@@ -0,0 +1,25 @@
+use strict;
+use Math::BigInt;
+use Test::More tests => 11;
+
+use_ok('Language::MzScheme');
+
+my $env = Language::MzScheme->new;
+
+my $obj = $env->define('bigint', Math::BigInt->new(0x12345));
+is($obj->('as_hex'), "0x12345", 'auto context');
+is($env->eval("(bigint 'as_hex)"), '0x12345', '...eval()');
+is($obj->('as_hex@'), "(0x12345)", 'array context');
+is($obj->('as_hex?'), "#t", 'bool context');
+
+my $class = $env->define('Math::BigInt');
+is($class->('VERSION'), Math::BigInt->VERSION, 'class method');
+is($env->eval("(Math::BigInt 'VERSION)"), Math::BigInt->VERSION, '...eval()');
+is($env->eval("((bigint 'can 'as_hex) bigint)"), '0x12345', 'nested invocation');
+
+my $as_hex = $env->lambda(Math::BigInt->can('as_hex'));
+is($class->as_perl_data, 'Math::BigInt', '$class->as_perl_data');
+isa_ok($obj->as_perl_data, 'Math::BigInt', '$obj->as_perl_data');
+is($as_hex->as_perl_data, Math::BigInt->can('as_hex'), '$code->as_perl_data');
+
+1;
Added: mzscheme/Language-MzScheme/t/4-data.t
==============================================================================
--- (empty file)
+++ mzscheme/Language-MzScheme/t/4-data.t Sun Jun 13 00:09:52 2004
@@ -0,0 +1,30 @@
+use strict;
+use Math::BigInt;
+use Test::More tests => 13;
+
+use_ok('Language::MzScheme');
+
+my $env = Language::MzScheme->new;
+my $identity = $env->eval('(lambda (x) x)');
+my $data = [
+ 1792,
+ "string",
+ [1 .. 6],
+ ["a" .. "f"],
+ [[-1, -2], [-3, -4], [-5, -6]],
+ { a => 1, b => 2 },
+ undef,
+ \undef,
+ \&use_ok,
+ Math::BigInt->new,
+];
+
+foreach my $datum (@$data, $data, \$data) {
+ my $scheme_value = $identity->($datum);
+ is_deeply(
+ $scheme_value->as_perl_data,
+ $datum,
+ "roundtrip: ".$scheme_value->as_write,
+ );
+}
+
Added: mzscheme/Language-MzScheme/t/5-perl.t
==============================================================================
--- (empty file)
+++ mzscheme/Language-MzScheme/t/5-perl.t Sun Jun 13 00:09:52 2004
@@ -0,0 +1,28 @@
+use strict;
+use Math::Trig ();
+use Test::More tests => 13;
+
+use_ok('Language::MzScheme');
+
+my $env = Language::MzScheme->new;
+is($env->perl_use('Math::Trig'), 'Math::Trig', 'perl_use');
+is($env->perl_require('Math::Trig'), 'Math::Trig', 'perl_require - with ::');
+is($env->perl_require('Math/Trig.pm'), 'Math::Trig', 'perl_require - with /');
+
+is($env->eval('(perl-use Math::Trig)'), 'Math::Trig', 'perl-use');
+is($env->eval('(perl-eval "$0")'), $0, 'perl-eval');
+
+ok($env->eval("(Math::Trig 'isa? 'Exporter)"), 'isa? - true');
+ok(!$env->eval("(Math::Trig 'isa? 'Exploder)"), 'isa? - false');
+
+ok($env->eval("(Math::Trig 'can? 'pi)"), 'can? - true');
+ok(!$env->eval("(Math::Trig 'can? 'pie)"), 'can? - false');
+
+is($env->eval("(GD)"), Math::Trig::GD, 'invocation - import');
+is($env->eval("(Math::Trig::GD)"), Math::Trig::GD, 'invocation - full name');
+cmp_ok(
+ $env->eval("(deg2deg 1792)"),
+ '==',
+ Math::Trig::deg2deg(1792),
+ 'invocation - with parameters'
+);
Added: mzscheme/Language-MzScheme/t/6-error.t
==============================================================================
--- (empty file)
+++ mzscheme/Language-MzScheme/t/6-error.t Sun Jun 13 00:09:52 2004
@@ -0,0 +1,31 @@
+use strict;
+use Test::More tests => 7;
+
+use_ok('Language::MzScheme');
+
+my $env = Language::MzScheme->new;
+
+my $obj = eval { $env->eval('this is an error') };
+isa_ok($obj, 'Language::MzScheme::Object', 'return value from eval {}');
+is($obj->as_perl_data, undef, 'return value from {} is undefined');
+
+$SIG{__DIE__} = sub { show_ok(@_); goto &next };
+$env->eval('(not well formed');
+
+sub next {
+ $SIG{__DIE__} = sub { show_ok(@_); goto &last };
+ $env->eval('(perl-eval "die q(died from perl)")');
+}
+
+sub last {
+ $SIG{__WARN__} = sub { return };
+ my $obj = eval { $env->eval('this is an error') };
+ isa_ok($obj, 'Language::MzScheme::Object', 'return value from eval {}');
+ is($obj->as_perl_data, undef, 'return value from {} is undefined');
+ exit;
+}
+
+sub show_ok {
+ my $err = shift; chomp $err;
+ ok($err, "error captured with \$SIG{__DIE__}: $err");
+}
More information about the Rt-commit
mailing list