[Rt-commit] [svn] r1052 - in mzscheme: . Inline-MzScheme
Inline-MzScheme/lib/Inline Inline-MzScheme/t
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 15:37:04 EDT 2004
Author: autrijus
Date: Thu Jun 10 15:37:03 2004
New Revision: 1052
Modified:
mzscheme/ (props changed)
mzscheme/Inline-MzScheme/Changes
mzscheme/Inline-MzScheme/MANIFEST.SKIP
mzscheme/Inline-MzScheme/META.yml
mzscheme/Inline-MzScheme/Makefile.PL
mzscheme/Inline-MzScheme/SIGNATURE
mzscheme/Inline-MzScheme/lib/Inline/MzScheme.pm
mzscheme/Inline-MzScheme/t/1-basic.t
mzscheme/Language-MzScheme/Changes
mzscheme/Language-MzScheme/MANIFEST
mzscheme/Language-MzScheme/META.yml
mzscheme/Language-MzScheme/Makefile.PL
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:
----------------------------------------------------------------------
r5534 at not: autrijus | 2004-06-10T17:34:33.032406Z
* This be 0.04 for both modules.
* Transparent calls across perl/scheme boundaries.
* Perl objects and classes may now be bound as scheme primitives.
* To invoke perl objects from scheme, write:
(object 'method arg1 arg2 ...)
* All scheme value types turned into properly overloaded perl objects.
* Plain, blessed, and coderef perl types turned into scheme objects.
* Deep copying into perl data structure supported as $obj->as_perl_data.
* Improved documentations and tests.
* Now exports all global user-defined symbols into perl.
----------------------------------------------------------------------
Modified: mzscheme/Inline-MzScheme/Changes
==============================================================================
--- mzscheme/Inline-MzScheme/Changes (original)
+++ mzscheme/Inline-MzScheme/Changes Thu Jun 10 15:37:03 2004
@@ -1,3 +1,17 @@
+[Changes for 0.04 - June 11, 2004]
+
+Improved documentations and tests.
+
+Now exports all global user-defined symbols into Perl.
+
+Perl objects and subroutines may also be imported into Scheme.
+
+Invoking Perl object methods from Scheme now works.
+
+[Changes for 0.03 - June 9, 2004]
+
+Change to adapt to 0.03's API.
+
[Changes for 0.02 - June 7, 2004]
Uses Language::MzScheme 0.02's new functions, like SCHEME_PROCP(),
Modified: mzscheme/Inline-MzScheme/MANIFEST.SKIP
==============================================================================
--- mzscheme/Inline-MzScheme/MANIFEST.SKIP (original)
+++ mzscheme/Inline-MzScheme/MANIFEST.SKIP Thu Jun 10 15:37:03 2004
@@ -10,6 +10,7 @@
^MakeMaker-\d
^.*\.hi
^_Inline
+^t/_Inline
^blibdirs
^pm_to_blib
~$
Modified: mzscheme/Inline-MzScheme/META.yml
==============================================================================
--- mzscheme/Inline-MzScheme/META.yml (original)
+++ mzscheme/Inline-MzScheme/META.yml Thu Jun 10 15:37:03 2004
@@ -1,12 +1,14 @@
name: Inline-MzScheme
-version: 0.03
+version: 0.04
abstract: Inline module for the PLT MzScheme interpreter
author: Autrijus Tang <autrijus at autrijus.org>
license: perl
distribution_type: module
+build_requires:
+ Test::More: 0
requires:
Inline: 0.43
- Language::MzScheme: 0.03
+ Language::MzScheme: 0.04
no_index:
directory:
- inc
Modified: mzscheme/Inline-MzScheme/Makefile.PL
==============================================================================
--- mzscheme/Inline-MzScheme/Makefile.PL (original)
+++ mzscheme/Inline-MzScheme/Makefile.PL Thu Jun 10 15:37:03 2004
@@ -8,10 +8,10 @@
abstract_from('lib/Inline/MzScheme.pm');
author('Autrijus Tang <autrijus at autrijus.org>');
license('perl');
+build_requires('Test::More');
requires(qw(
Inline 0.43
- Language::MzScheme 0.03
+ Language::MzScheme 0.04
));
-can_cc() or die "This module requires a C compiler";
WriteAll( sign => 1 );
Modified: mzscheme/Inline-MzScheme/SIGNATURE
==============================================================================
--- mzscheme/Inline-MzScheme/SIGNATURE (original)
+++ mzscheme/Inline-MzScheme/SIGNATURE Thu Jun 10 15:37:03 2004
@@ -14,11 +14,11 @@
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
-SHA1 b2971fcca1f1bc94633af59eec3ba9b0bc9dedc9 Changes
+SHA1 61220651880e45d32a005e73d33d22d587be37a9 Changes
SHA1 3ccdfbd7b06ce8f3703e818323d7aba879102d8b MANIFEST
-SHA1 507a90272299ca2360c61c257b410a2b0d82dbbd MANIFEST.SKIP
-SHA1 38a50614e39e4f6400fcddc35c449bebd83087ea META.yml
-SHA1 37d44747b6dedbb4fec4a27132059e1487201c6b Makefile.PL
+SHA1 6fa56ce905a85a21ab38ace330ed5b54c07cb36e MANIFEST.SKIP
+SHA1 6e4ac8bf39ede39db9c8fa203933bcf7b2c6bfce META.yml
+SHA1 2c33b571190353948bbaf6e3771e5aceb5680b3f Makefile.PL
SHA1 015ef794b70a926280cbbe8c8d34c1e1329896df README
SHA1 2b65fc08c268c16ae7097d800bacccc7b8c9c905 inc/Module/Install.pm
SHA1 fd56d5c793014bccac2cd1e61926c4da8538ef99 inc/Module/Install/Base.pm
@@ -28,13 +28,13 @@
SHA1 207dfa13341a374fc78325fbeb99bc36659aef2d inc/Module/Install/Metadata.pm
SHA1 aff9341a15c04faec47089851e43d9d4061337e7 inc/Module/Install/Win32.pm
SHA1 8e0d347ca21bc18b380d9d1aa5910b8d078a76b7 inc/Module/Install/WriteAll.pm
-SHA1 d60586918eac112723e55d21d9ef20c0c58971e5 lib/Inline/MzScheme.pm
+SHA1 cf084d01f087f5e221065b09e8502aa1496ad356 lib/Inline/MzScheme.pm
SHA1 63c7ea0cfdd7643aa113c260eec9c9bf0a6ee8a0 t/0-signature.t
-SHA1 9f4aeb17d8e74dd434b37e5d6e35c2fd82f67df3 t/1-basic.t
+SHA1 7e990a6d60fe7cdf878a84ab7f8afcdc08fea037 t/1-basic.t
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.2.3 (FreeBSD)
-iD8DBQFAxk8FtLPdNzw1AaARAhjRAJ4qWR18r7DBUiSbHQVkj+XBhdzuTgCff6hW
-hVZDBcIBFz/YN0SDOfVfX80=
-=8Rmb
+iD8DBQFAyLMitLPdNzw1AaARAtUXAKC3vYQv+N6HtKKq5lThobGoumphoQCfYnI5
+zPQWqzJ7N9fs2MKP7LrDNJg=
+=49c9
-----END PGP SIGNATURE-----
Modified: mzscheme/Inline-MzScheme/lib/Inline/MzScheme.pm
==============================================================================
--- mzscheme/Inline-MzScheme/lib/Inline/MzScheme.pm (original)
+++ mzscheme/Inline-MzScheme/lib/Inline/MzScheme.pm Thu Jun 10 15:37:03 2004
@@ -1,13 +1,11 @@
package Inline::MzScheme;
-$Inline::MzScheme::VERSION = '0.03';
+$Inline::MzScheme::VERSION = '0.04';
@Inline::MzScheme::ISA = qw(Inline);
use strict;
-use B ();
use Inline ();
use Language::MzScheme ();
-use Carp qw(croak confess);
=head1 NAME
@@ -15,19 +13,55 @@
=head1 VERSION
-This document describes version 0.03 of Inline::MzScheme, released
-June 9, 2004.
+This document describes version 0.04 of Inline::MzScheme, released
+June 11, 2004.
=head1 SYNOPSIS
- use Inline MzScheme => '(define (square x) (* x x))';
- print square(10); # 100
+ use subs 'perl_multiply'; # have to declare before Inline runs
+
+ use Math::BigInt;
+ use Inline MzScheme => '
+ (define (square x) (car (perl-multiply x x)))
+ (define assoc-list '((1 . 2) (3 . 4) (5 . 6)))
+ (define linked-list '(1 2 3 4 5 6))
+ (define hex-string (car (bigint 'as_hex)))
+ ', (bigint => Math::BigInt->new(1792));
+
+ sub perl_multiply { $_[0] * $_[1] }
+
+ print square(10); # 100
+ print $hex_string; # 0x700
+ print $assoc_list->{1}; # 2
+ print $linked_list->[3]; # 4
=head1 DESCRIPTION
This module allows you to add blocks of Scheme code to your Perl
-scripts and modules. Any procedures you define in your Scheme code
-will be available in Perl.
+scripts and modules.
+
+All user-defined procedures in your Scheme code will be available
+as Perl subroutines; association lists and hash tables are available
+as Perl hash refereces; lists and vectors available as array references;
+boxed values become scalar references.
+
+Perl subroutines in the same package are imported as Scheme primitives,
+as long as they are declared before the C<use Inline MzScheme> line.
+
+Non-word characters in Scheme identifiers are turned into C<_> for Perl.
+Underscores in Perl identifiers are turned into C<-> for Scheme.
+
+Additional objects, classes and procedures may be imported into Scheme,
+by passing them as config parameters to C<use Inline>. See L<Inline>
+for details about this syntax.
+
+You can invoke perl objects in Scheme code with the syntax:
+
+ (object 'method arg1 arg2 ...)
+
+If your method takes named argument lists, this will do:
+
+ (object 'method 'key1 val1 'key2 val2)
For information about handling MzScheme data in Perl, please see
L<Language::MzScheme>. This module is mostly a wrapper around
@@ -49,10 +83,11 @@
# check options
sub validate {
my $self = shift;
+ my $env = $self->{env} ||= Language::MzScheme->basic_env;
while (@_ >= 2) {
- my ($key, $value) = (shift, shift);
- croak("Unsupported option found: \"$key\".");
+ my ($key, $value) = (shift, shift);
+ $env->define($key, $value) if $key =~ /^\w/;
}
}
@@ -71,63 +106,40 @@
close(OBJECT) or die "Unable to close object file: $obj : $!";
}
-my $block_regex;
-$block_regex = qr/(\((?:(?>[^()]+)|(??{$block_regex}))*\))/;
-
# load the code into the interpreter
sub load {
my $self = shift;
my $code = $self->{API}{code};
my $pkg = $self->{API}{pkg} || 'main';
- my $env = Language::MzScheme::scheme_basic_env();
+ my $env = $self->{env} ||= Language::MzScheme->basic_env;
- foreach my $chunk (split($block_regex, $code)) {
- $chunk =~ /\S/ or next;
- my $result = Language::MzScheme::scheme_eval_string($chunk, $env) or next;
- croak "Inline::MzScheme: Problem evaluating code:\n$chunk\n\nReason: $@" if $@;
+ my %sym = map(
+ ( $_ => 1 ),
+ $env->eval('(namespace-mapped-symbols)') =~ /([^\s()]+)/g
+ );
+
+ $env->eval($code);
+
+ no strict 'refs';
+
+ foreach my $sym (sort keys %{"$pkg\::"}) {
+ my $code = *{${"$pkg\::"}{$sym}}{CODE} or next;
+ $sym =~ tr/_/-/;
+ next if $sym{$sym}++;
+ $env->define($sym, $code);
}
- # look for possible global defines
- while ($code =~ /\(define\s+\W*(\S+)/g) {
- my $name = $1;
-
- # try to lookup a procedure object
- my $sym = Language::MzScheme::scheme_intern_symbol($name) or next;
- my $proc = Language::MzScheme::scheme_lookup_global($sym, $env) or next;
- Language::MzScheme::SCHEME_PROCP($proc) or next;
-
- no strict 'refs';
- *{"${pkg}::$name"} = sub {
- my $list = [map Language::MzScheme::mzscheme_from_perl_scalar($_), @_];
-
- my $out = Language::MzScheme::scheme_make_string_output_port() or return;
- my $rv = Language::MzScheme::scheme_apply($proc, scalar @$list, $list) or return;
-
- Language::MzScheme::scheme_display($rv, $out);
- return Language::MzScheme::scheme_get_string_output($out);
- } if 0; # XXX - (typemap(in) Scheme_Object**) segfaults
-
- # the unsafe version
- *{"${pkg}::$name"} = sub {
- my $list = join(
- ' ',
- map {
- B::svref_2object(\$_)->FLAGS & ( B::SVf_IOK() | B::SVf_NOK() ) ? $_ : do {
- my $str = $_;
- $str =~ s/(?:["\\])/\\/g;
- qq("$str");
- };
- } @_
- );
-
- my $out = Language::MzScheme::scheme_make_string_output_port() or return;
- my $rv = Language::MzScheme::scheme_eval_string("($name $list)", $env) or return;
-
- Language::MzScheme::scheme_display($rv, $out);
- return Language::MzScheme::scheme_get_string_output($out);
- };
+ SYMBOL:
+ foreach my $sym (grep !$sym{$_}, $env->eval('(namespace-mapped-symbols)') =~ /([^\s()]+)/g) {
+ my $obj = $env->lookup($sym);
+ $sym =~ s/\W/_/g;
+ foreach my $type (qw( CODE GLOB )) {
+ $obj->isa($type) or next;
+ *{"$pkg\::$sym"} = $obj->can('to_'.lc($type).'ref')->($obj);
+ next SYMBOL;
+ }
+ *{"$pkg\::$sym"} = \$obj;
}
-
}
# no info implementation yet
Modified: mzscheme/Inline-MzScheme/t/1-basic.t
==============================================================================
--- mzscheme/Inline-MzScheme/t/1-basic.t (original)
+++ mzscheme/Inline-MzScheme/t/1-basic.t Thu Jun 10 15:37:03 2004
@@ -1,13 +1,14 @@
#!/usr/bin/perl
use strict;
-use Test;
-
-BEGIN { plan tests => 3 }
+use subs 'perl_multiply'; # have to pre-declare before Inline runs
+use Test::More tests => 6;
+use Math::BigInt;
use Inline MzScheme => q{
-(define (square x) (* x x))
+(define (square x)
+ (car (perl-multiply x x)))
(define plus_two
(lambda (num)
@@ -17,13 +18,24 @@
(lambda (str)
(string-append str "two")))
-};
+(define assoc-list '((1 . 2) (3 . 4) (5 . 6)))
+(define linked-list '(1 2 3 4 5 6))
+(define hex-string (car (bigint 'as_hex)))
+
+}, (bigint => Math::BigInt->new(1792));
+
+sub perl_multiply { $_[0] * $_[1] }
my $three = plus_two(1);
-ok($three, 3);
+is($three, 3, 'calling into scheme, returns number');
my $one_two = cat_two("one");
-ok($one_two, "onetwo");
+is($one_two, "onetwo", 'calling into scheme, returns string');
my $squared = square(1.61828);
-ok(substr($squared, 0, 5), 2.618);
+is(int($squared * 1000), 2618, 'calls into perl inside scheme');
+
+is($assoc_list->{1}, 2, 'received hash from scheme');
+is($linked_list->[3], 4, 'received list from scheme');
+is($hex_string, '0x700', 'received scalar from scheme');
+1;
Modified: mzscheme/Language-MzScheme/Changes
==============================================================================
--- mzscheme/Language-MzScheme/Changes (original)
+++ mzscheme/Language-MzScheme/Changes Thu Jun 10 15:37:03 2004
@@ -1,3 +1,24 @@
+[Changes for 0.04 - June 11, 2004]
+
+Backported to SWIG 1.3.19 and earlier versions.
+
+Methods refactored into Language::MzScheme::Object and
+Language::MzScheme::Env classes.
+
+All scheme value types turned into properly overloaded Perl objects.
+Type checking methods, eg. ->isa('CODE'), are also implemented.
+
+Deep copying into perl data structure supported as $obj->as_perl_data.
+
+Previously exported symbols now become class methods for Language::MzScheme,
+with the prefix 'mzscheme_', 'scheme_' and 'SCHEME_' removed.
+
+Transparent procedure calls across perl/scheme boundaries.
+
+Perl objects and classes may now be bound as scheme primitives.
+To invoke perl objects from scheme, do this:
+ (object 'method arg1 arg2 ...)
+
[Changes for 0.03 - June 9, 2004]
Build cleanly on SWIG 1.3.21, which we now requires.
Modified: mzscheme/Language-MzScheme/MANIFEST
==============================================================================
--- mzscheme/Language-MzScheme/MANIFEST (original)
+++ mzscheme/Language-MzScheme/MANIFEST Thu Jun 10 15:37:03 2004
@@ -8,6 +8,8 @@
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
lib/Language/MzScheme.pm
+lib/Language/MzScheme/Env.pm
+lib/Language/MzScheme/Object.pm
Makefile.PL
MANIFEST This list of files
MANIFEST.SKIP
Modified: mzscheme/Language-MzScheme/META.yml
==============================================================================
--- mzscheme/Language-MzScheme/META.yml (original)
+++ mzscheme/Language-MzScheme/META.yml Thu Jun 10 15:37:03 2004
@@ -1,5 +1,5 @@
name: Language-MzScheme
-version: 0.03
+version: 0.04
abstract: Perl bindings to PLT MzScheme
author: Autrijus Tang <autrijus at autrijus.org>
license: perl
Modified: mzscheme/Language-MzScheme/Makefile.PL
==============================================================================
--- mzscheme/Language-MzScheme/Makefile.PL (original)
+++ mzscheme/Language-MzScheme/Makefile.PL Thu Jun 10 15:37:03 2004
@@ -47,6 +47,7 @@
makemaker_args(
LIBS => "-L$plt_path/lib -lmzgc -lmzscheme ".run(qw(swig -perl -ldflags)),
INC => "-I$include",
+ OPTIMIZE => '-g',
OBJECT => "mzscheme_wrap$Config{obj_ext}",
);
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 15:37:03 2004
@@ -1,5 +1,5 @@
package Language::MzScheme;
-$Language::MzScheme::VERSION = '0.03';
+$Language::MzScheme::VERSION = '0.04';
use strict;
use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
@@ -19,29 +19,25 @@
=head1 VERSION
-This document describes version 0.03 of Language::MzScheme, released
-June 9, 2004.
+This document describes version 0.04 of Language::MzScheme, released
+June 11, 2004.
=head1 SYNOPSIS
use strict;
- use Language::MzScheme ':all';
- my $env = scheme_basic_env();
- my $out = scheme_get_param($scheme_config, $MZCONFIG_OUTPUT_PORT);
- my $val = scheme_eval_string('(+ 1 2)', $env);
- scheme_display($val, $out);
- scheme_display(scheme_make_char("\n"), $out);
+ use Language::MzScheme;
+ my $env = Language::MzScheme->basic_env;
+ my $val = $env->eval('(+ 1 2)');
+
+ # See t/1-basic.t in the source distribution for more!
=head1 DESCRIPTION
This module provides Perl bindings to PLT's MzScheme language.
-Currently, it simply exports all C enums, functions and symbols found in
-the MzScheme's extension table into Perl space, without any further
-processing.
-
-Object-oriented wrappers and Perl-based primitives are planned for the
-next few versions.
+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.
=cut
@@ -56,14 +52,16 @@
*$sym = sub { shift; goto &$func } unless defined &$sym;
}
- $Language::MzScheme::Initialized++;
-}
+ 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;
+ }
-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 };
+ *VERSION = \&UNIVERSAL::VERSION;
+ $Language::MzScheme::Initialized++;
}
1;
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 Thu Jun 10 15:37:03 2004
@@ -7,9 +7,11 @@
sub eval {
my $self = shift;
- UNIVERSAL::isa($_[0], S."::Object")
+ my $obj = UNIVERSAL::isa($_[0], S."::Object")
? S->eval($_[0], $self)
: S->eval_string_all($_[0], $self, 1);
+ $Objects{+$obj} ||= $self if ref($obj);
+ return $obj;
}
sub define {
@@ -21,38 +23,31 @@
sub lambda {
my ($self, $code) = @_;
- my $obj = S->make_perl_prim_w_arity($code, "$code", 0, -1);
- $Objects{+$obj} = [$self, 'XXX'];
+ 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;
return $obj;
}
sub apply {
my ($self, $name) = splice(@_, 0, 2);
-
- require B;
- my $list = join(
- ' ',
- map {
- UNIVERSAL::isa($_, 'Language::MzScheme::Object')
- ? '(quote '.$_->write.')' :
- B::svref_2object(\$_)->FLAGS & ( B::SVf_IOK() | B::SVf_NOK() ) ? $_ : do {
- my $str = $_;
- $str =~ s/(?=["\\])/\\/g;
- qq("$str");
- };
- } @_
- );
- $self->eval("($name $list)");
-
-# my $list = S->from_perl_scalar($_[0]);
-# return S->apply_to_list($self->lookup($name), $list);
+ @_ = 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);
+ return $obj;
}
sub lookup {
my ($self, $name) = @_;
+
+ return $name if UNIVERSAL::isa($name, S.'::Object') and $name->isa('CODE');
+
my $sym = S->intern_symbol($name);
my $obj = S->lookup_global($sym, $self);
- $Objects{+$obj} = [$self, $name];
+ $Objects{+$obj} ||= $self;
return $obj;
}
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 Thu Jun 10 15:37:03 2004
@@ -2,39 +2,47 @@
@_p_Scheme_Object::ISA = __PACKAGE__;
use strict;
+use vars '%Proc';
use constant S => "Language::MzScheme";
use overload (
'bool' => \&to_bool,
'""' => \&to_string,
'0+' => \&to_number,
- '&{}' => \&to_code,
- '@{}' => \&to_array,
- '%{}' => \&to_hash,
- '${}' => \&to_scalar,
- '*{}' => \&to_glob,
- '<>' => \&to_iterator,
'=' => \&to_lvalue,
+ '&{}' => \&to_coderef,
+ '%{}' => \&to_hashref,
+ '@{}' => \&to_arrayref,
+ '*{}' => \&to_globref,
+ '${}' => \&to_scalarref,
+ '<>' => \&read,
fallback => 1,
);
-foreach my $proc (qw( car cdr cadr caar cddr caddr )) {
+foreach my $proc (qw( car cdr cadr caar cddr )) {
+ no strict 'refs';
+ my $code = S."::SCHEME_\U$proc";
+ *$proc = sub { $_[0]->bless($code->($_[0])) };
+}
+
+foreach my $proc (qw( caddr read write )) {
no strict 'refs';
my $code = S."::scheme_$proc";
*$proc = sub { $_[0]->bless($code->($_[0])) };
}
-sub display {
- my $self = shift;
- my $out = S->make_string_output_port();
- S->display($self, $out);
- return S->get_string_output($out);
+foreach my $proc (qw( read-char write-char )) {
+ no strict 'refs';
+ my $sym = $proc;
+ $sym =~ s/\W/_/g;
+ *$sym = sub { $_[0]->apply($proc, $_[0]) };
}
-sub write {
- my $self = shift;
- my $out = S->make_string_output_port();
- S->display($self, $out);
- return S->get_string_output($out);
+foreach my $proc (qw( eval apply lambda lookup )) {
+ no strict 'refs';
+ *$proc = sub {
+ my $env = shift(@_)->env;
+ $env->can($proc)->($env, @_);
+ };
}
sub to_bool {
@@ -48,22 +56,20 @@
S->CHARP($self) ? S->CHAR_VAL($self) :
S->VOIDP($self) ? undef :
S->FALSEP($self) ? '' :
- $self->display;
+ $self->as_display;
}
sub to_number {
my $self = shift;
S->VOIDP($self) ? undef :
S->FALSEP($self) ? 0 :
- $self->display;
+ $self->as_display;
}
sub env {
my $self = shift;
- @{
- $Language::MzScheme::Env::Objects{+$self}
- or die "Cannot find associated environment";
- };
+ $Language::MzScheme::Env::Objects{+$self}
+ or die "Cannot find associated environment";
}
sub bless {
@@ -73,25 +79,107 @@
return $obj;
}
-sub to_code {
+sub to_coderef {
my $self = shift;
S->PROCP($self) or die "Value $self is not a CODE";
- $Language::MzScheme::Object::Proc{+$self} ||= do {
- my ($env, $name) = $self->env;
- sub { $env->apply($name, @_) };
- };
+ $Proc{+$self} ||= sub { $self->apply($self, @_) };
+}
+
+my $Cons;
+sub to_hashref {
+ my $self = shift;
+ my $alist = (S->HASHTP($self)) ? $self->apply(
+ 'hash-table-map',
+ $self,
+ $Cons ||= $self->lookup('cons'),
+ ) : $self;
+
+ my %rv;
+ while (my $obj = $alist->car) {
+ $rv{$obj->car} = $obj->cdr;
+ $alist = $alist->cdr;
+ }
+ return \%rv;
+}
+
+sub to_arrayref {
+ my $self = shift;
+
+ if (S->VECTORP($self)) {
+ return [ map $self->bless($_), @{S->VEC_BASE($self)} ];
+ }
+
+ return [
+ map +($self->car, $self = $self->cdr)[0],
+ 1..S->proper_list_length($self)
+ ];
+}
+
+sub to_scalarref {
+ my $self = shift;
+ return \S->BOX_VAL($self);
+}
+
+sub as_display {
+ my $self = shift;
+ my $out = S->make_string_output_port;
+ S->display($self, $out);
+ return S->get_string_output($out);
+}
+
+sub as_write {
+ my $self = shift;
+ my $out = S->make_string_output_port;
+ S->display($self, $out);
+ return S->get_string_output($out);
+}
+
+sub as_perl_data {
+ my $self = shift;
+
+ if ( $self->isa('CODE') ) {
+ return $self->to_coderef;
+ }
+ elsif ( $self->isa('HASH') and !S->NULLP($self) ) {
+ my $hash = $self->to_hashref;
+ $hash->{$_} = $hash->{$_}->as_perl_data for keys %$hash;
+ return $hash;
+ }
+ elsif ( $self->isa('ARRAY') ) {
+ return [ map $_->as_perl_data, @{$self->to_arrayref} ];
+ }
+ elsif ( $self->isa('GLOB') ) {
+ return $self; # XXX -- doesn't really know what to do
+ }
+ elsif ( $self->isa('SCALAR') ) {
+ return \${$self->to_scalarref}->as_perl_data;
+ }
+ else {
+ $self->to_string;
+ }
}
sub isa {
my ($self, $type) = @_;
- $self->SUPER::isa($type) or
- ($type eq 'CODE') ? S->PROCP($self) :
- ($type eq 'ARRAY') ? S->LISTP($self) || S->VECTORP($self) :
- ($type eq 'HASH') ? S->BUCKTP($self) || S->HASHTP($self) :
- ($type eq 'GLOB') ? S->INPORTP($self) || S->OUTPORTP($self)
- ($type eq 'SCALAR') ? S->BOXP($self) || : undef;
+ ($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
+ );
}
1;
Modified: mzscheme/Language-MzScheme/mzscheme.c
==============================================================================
--- mzscheme/Language-MzScheme/mzscheme.c (original)
+++ mzscheme/Language-MzScheme/mzscheme.c Thu Jun 10 15:37:03 2004
@@ -17,26 +17,37 @@
}
Scheme_Object *
+mzscheme_make_perl_object_w_arity (Perl_Scalar object, const char *name, int mina, int maxa) {
+ SvREFCNT_inc((SV *)object);
+ return scheme_make_closed_prim_w_arity(
+ &_mzscheme_closed_prim_OBJ,
+ (void *)object, name, mina, maxa
+ );
+}
+
+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 :
+ ? temp :
+ sv_isobject(SvRV(sv))
+ ? mzscheme_make_perl_object_w_arity((Perl_Scalar)SvRV(sv), SvPV(sv, PL_na), 0, -1) :
+ (SvTYPE(SvRV(sv)) == SVt_PVCV)
+ ? mzscheme_make_perl_prim_w_arity((Perl_Scalar)SvRV(sv), SvPV(sv, PL_na), 0, -1)
+ : 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) ) : scheme_void
);
}
-Scheme_Object *
-_mzscheme_closed_prim_CV (void *callback, int argc, Scheme_Object **argv) {
+void
+_mzscheme_enter (int argc, Scheme_Object **argv) {
dSP ;
- Scheme_Object **return_values;
- I32 count, i;
+ int i;
push_scope() ;
SAVETMPS;
@@ -51,11 +62,37 @@
}
PUTBACK ;
+}
- count = call_sv((SV*)callback, G_ARRAY);
+void
+_mzscheme_enter_with_sv (Perl_Scalar sv, int argc, Scheme_Object **argv) {
+ dSP ;
+ int i;
- SPAGAIN ;
+ push_scope() ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ EXTEND(SP, argc);
+
+ 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);
+ }
+
+ PUTBACK ;
+}
+
+Scheme_Object *
+_mzscheme_leave (int count) {
+ dSP ;
+ Scheme_Object **return_values;
+ int i;
+
+ SPAGAIN ;
return_values = (Scheme_Object **) malloc((count+2)*sizeof(Scheme_Object *));
for (i = count - 1; i >= 0 ; i--) {
@@ -69,8 +106,27 @@
return scheme_build_list((int)count, return_values);
}
+Scheme_Object *
+_mzscheme_closed_prim_CV (void *callback, int argc, Scheme_Object **argv) {
+ _mzscheme_enter(argc, argv);
+ return _mzscheme_leave( (int)call_sv((SV*)callback, G_ARRAY) );
+}
+
+Scheme_Object *
+_mzscheme_closed_prim_OBJ (void *callback, int argc, Scheme_Object **argv) {
+ const 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) );
+}
+
AV *
-_mzscheme_objects_AV (Scheme_Object ** objects) {
+_mzscheme_objects_AV (void **objects, char *type) {
AV *myav;
SV **svs;
int i = 0, len = 0;
@@ -80,7 +136,7 @@
svs = (SV **)malloc(len*sizeof(SV *));
for (i = 0; i < len ; i++) {
svs[i] = sv_newmortal();
- sv_setref_pv((SV*)svs[i], (char *)&SWIGTYPE_p_Scheme_Object, objects[i]);
+ SWIG_MakePtr(svs[i], (void *)objects[i], SWIGTYPE_p_Scheme_Object, 0);
};
myav = av_make(len, svs);
free(svs);
Modified: mzscheme/Language-MzScheme/mzscheme.h
==============================================================================
--- mzscheme/Language-MzScheme/mzscheme.h (original)
+++ mzscheme/Language-MzScheme/mzscheme.h Thu Jun 10 15:37:03 2004
@@ -1,4 +1,5 @@
typedef SV* Perl_Scalar;
-AV* _mzscheme_objects_AV (Scheme_Object ** objects);
+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);
Modified: mzscheme/Language-MzScheme/mzscheme.i
==============================================================================
--- mzscheme/Language-MzScheme/mzscheme.i (original)
+++ mzscheme/Language-MzScheme/mzscheme.i Thu Jun 10 15:37:03 2004
@@ -26,7 +26,7 @@
$1 = (Scheme_Object **) malloc((len+2)*sizeof(Scheme_Object *));
for (i = 0; i <= len; i++) {
tv = av_fetch(tempav, i, 0);
- $1[i] = (Scheme_Object *) SvIV((SV*)SvRV(*tv));
+ SWIG_ConvertPtr((SV *)*tv, (void **) &$1[i], SWIGTYPE_p_Scheme_Object, 0);
}
$1[i] = NULL;
};
@@ -36,13 +36,14 @@
}
%typemap(out) Scheme_Object ** {
- $result = newRV((SV *)_mzscheme_objects_AV($1));
+ $result = newRV((SV *)_mzscheme_objects_AV((void **)$1, (char *)&SWIGTYPE_p_Scheme_Object));
sv_2mortal($result);
argvi++;
}
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_from_perl_scalar (Perl_Scalar sv);
Scheme_Type SCHEME_TYPE(Scheme_Object *obj);
@@ -68,9 +69,14 @@
int SCHEME_EOFP(Scheme_Object *obj);
int SCHEME_VOIDP(Scheme_Object *obj);
+int SCHEME_NULLP(Scheme_Object *obj);
+int SCHEME_PAIRP(Scheme_Object *obj);
+
int SCHEME_LISTP(Scheme_Object *obj);
int SCHEME_VECTORP(Scheme_Object *obj);
+int SCHEME_BOXP(Scheme_Object *obj);
+
int SCHEME_BUCKTP(Scheme_Object *obj);
int SCHEME_HASHTP(Scheme_Object *obj);
@@ -98,6 +104,12 @@
Scheme_Object** SCHEME_VEC_ELS(Scheme_Object *obj);
Scheme_Object** SCHEME_VEC_BASE(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);
+
/*
#define SCHEME_ENVBOX_VAL(obj) (*((Scheme_Object **)(obj)))
#define SCHEME_WEAK_BOX_VAL(obj) SCHEME_BOX_VAL(obj)
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 15:37:03 2004
@@ -1,7 +1,6 @@
#!/usr/bin/perl
use strict;
-use Data::Dumper;
use Test::More 'no_plan';
use_ok('Language::MzScheme');
@@ -12,34 +11,54 @@
});
isa_ok($obj, "Language::MzScheme::Object");
-ok($obj, 'to_boolean');
-is($obj, 0, 'to_number');
-is($obj.1, "01", 'to_string');
-$env->eval(q{
+my $s_expression = q{
(define (square x) (* x x))
(define (tree-reverse tr)
(if (not (pair? tr))
tr
(cons (tree-reverse (cdr tr))
(tree-reverse (car tr)))))
-});
-my $code = $env->lookup('square');
-isa_ok($code, 'CODE', 'to_code');
-is($code->(4), 16, '->(), scheme-lambda');
+};
+$env->eval($s_expression);
is($env->eval('(square 4)'), 16, 'eval');
is($env->apply('tree-reverse', $env->eval(q{'(a b c)})), '(((() . c) . b) . a)', 'apply');
+is($env->lambda(sub { 1..10 })->(), '(1 2 3 4 5 6 7 8 9 10)', 'lambda');
-sub hello { (Hello => map $_, reverse @_) };
+ok($obj, 'to_boolean');
+is($obj, 0, 'to_number');
+is($obj."1", "01", 'to_string');
-my $hello = $env->define('perl-hello', \&hello);
-isa_ok($hello, 'CODE', 'define');
+ok(eq_array($env->eval("'(1 2 3)"), [1..3]), 'to_arrayref, list');
+ok(eq_array($env->eval("'#(1 2 3)"), [1..3]), 'to_arrayref, vector');
+isa_ok($env->eval("'#(1 2 3)"), 'ARRAY', 'vector');
-my $ditto = '...env->eval';
+ok(eq_hash($env->eval("'#hash((1 . 2) (3 . 4))"), {1..4}), 'to_hashref, hash');
+ok(eq_hash($env->eval("'((1 . 2) (3 . 4))"), {1..4}), 'to_hashref, alist');
+isa_ok($env->eval("'((1 . 2) (3 . 4))"), 'HASH', 'alist');
-is($hello, '#<primitive:'.\&hello.'>', 'primitive name');
-is($env->eval('perl-hello'), '#<primitive:'.\&hello.'>', $ditto);
+my $struct = $env->eval("'($s_expression)")->as_perl_data;
+ok(eq_array($struct->[0], ['define', ['square', 'x'], ['*', 'x', 'x']]), 'as_perl_data');
+
+is(${$env->eval("(box 123)")}, 123, 'to_scalarref, box');
+
+my $port = $env->apply('open-input-file', "$0");
+is($port->read_char, '#', 'read_char, port');
+is($port->read, '!/usr/bin/perl', 'read, port');
+is(<$port>, 'use', '<>, port');
+
+my $code = $env->lookup('square');
+isa_ok($code, 'CODE', 'to_coderef');
+is($code->(4), 16, '->(), scheme-lambda');
+
+my $lambda = sub { (Hello => map $_, reverse @_) };
+my $hello = $env->define('perl-hello', $lambda);
+isa_ok($hello, 'CODE', 'define');
+
+my $ditto = '...with ->eval';
+is($hello, "#<primitive:$lambda>", 'primitive name');
+is($env->eval('perl-hello'), "#<primitive:$lambda>", $ditto);
is($hello->("Scheme", "Perl"), '(Hello Perl Scheme)', '->(), perl-lambda');
is($env->eval('(perl-hello "Scheme" "Perl")'), '(Hello Perl Scheme)', $ditto);
@@ -53,4 +72,13 @@
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;
More information about the Rt-commit
mailing list