[Rt-commit] [svn] r1051 - 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 07:30:54 EDT 2004
Author: autrijus
Date: Thu Jun 10 07:30:53 2004
New Revision: 1051
Modified:
mzscheme/ (props changed)
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.i
mzscheme/Language-MzScheme/t/1-basic.t
Log:
----------------------------------------------------------------------
r5532 at not: autrijus | 2004-06-10T11:30:08.614921Z
* add overload mappings for all objects.
----------------------------------------------------------------------
Modified: mzscheme/Language-MzScheme/META.yml
==============================================================================
--- mzscheme/Language-MzScheme/META.yml (original)
+++ mzscheme/Language-MzScheme/META.yml Thu Jun 10 07:30:53 2004
@@ -4,6 +4,8 @@
author: Autrijus Tang <autrijus at autrijus.org>
license: perl
distribution_type: module
+build_requires:
+ Test::More: 0
no_index:
directory:
- inc
Modified: mzscheme/Language-MzScheme/Makefile.PL
==============================================================================
--- mzscheme/Language-MzScheme/Makefile.PL (original)
+++ mzscheme/Language-MzScheme/Makefile.PL Thu Jun 10 07:30:53 2004
@@ -10,6 +10,7 @@
abstract_from('lib/Language/MzScheme.pm');
author('Autrijus Tang <autrijus at autrijus.org>');
license('perl');
+build_requires('Test::More');
can_cc() or die "This module requires a C compiler";
my ($swig_version) = (run('swig', '-version') =~ /([\d\.]+)/g)
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 07:30:53 2004
@@ -7,9 +7,11 @@
use Language::MzScheme::Env;
use Language::MzScheme::Object;
- at EXPORT_OK = @EXPORT;
- at EXPORT = ();
-%EXPORT_TAGS = ( all => \@EXPORT_OK );
+BEGIN {
+ @EXPORT_OK = @EXPORT;
+ @EXPORT = ();
+ %EXPORT_TAGS = ( all => \@EXPORT_OK );
+}
=head1 NAME
@@ -45,6 +47,15 @@
if (!$Language::MzScheme::Initialized) {
mzscheme_init() if defined &mzscheme_init;
+
+ 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;
+ }
+
$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 Thu Jun 10 07:30:53 2004
@@ -1,41 +1,59 @@
package Language::MzScheme::Env;
@_p_Scheme_Env::ISA = __PACKAGE__;
+use vars '%Objects';
use strict;
use constant S => "Language::MzScheme";
sub eval {
my $self = shift;
UNIVERSAL::isa($_[0], S."::Object")
- ? S->eval(@_, $self)
- : S->eval_string(@_, $self);
+ ? S->eval($_[0], $self)
+ : S->eval_string_all($_[0], $self, 1);
}
sub define {
- my ($self, $sym, $code) = @_;
+ my ($self, $name, $code) = @_;
+ my $obj = $self->lambda($code);
+ S->add_global($name, $obj, $self);
+ return $self->lookup($name);
+}
- # 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 lambda {
+ my ($self, $code) = @_;
+ my $obj = S->make_perl_prim_w_arity($code, "$code", 0, -1);
+ $Objects{+$obj} = [$self, 'XXX'];
+ return $obj;
}
-sub export {
- my ($self, $sym) = @_;
+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);
+}
- 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)");
- };
+sub lookup {
+ my ($self, $name) = @_;
+ my $sym = S->intern_symbol($name);
+ my $obj = S->lookup_global($sym, $self);
+ $Objects{+$obj} = [$self, $name];
+ return $obj;
}
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 Thu Jun 10 07:30:53 2004
@@ -7,9 +7,22 @@
'bool' => \&to_bool,
'""' => \&to_string,
'0+' => \&to_number,
+ '&{}' => \&to_code,
+ '@{}' => \&to_array,
+ '%{}' => \&to_hash,
+ '${}' => \&to_scalar,
+ '*{}' => \&to_glob,
+ '<>' => \&to_iterator,
+ '=' => \&to_lvalue,
fallback => 1,
);
+foreach my $proc (qw( car cdr cadr caar cddr caddr )) {
+ 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();
@@ -17,6 +30,13 @@
return S->get_string_output($out);
}
+sub write {
+ 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));
@@ -38,4 +58,40 @@
$self->display;
}
+sub env {
+ my $self = shift;
+ @{
+ $Language::MzScheme::Env::Objects{+$self}
+ or die "Cannot find associated environment";
+ };
+}
+
+sub bless {
+ my ($self, $obj) = @_;
+ $Language::MzScheme::Env::Objects{+$obj}||=
+ $Language::MzScheme::Env::Objects{+$self};
+ return $obj;
+}
+
+sub to_code {
+ 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, @_) };
+ };
+}
+
+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;
+}
+
1;
Modified: mzscheme/Language-MzScheme/mzscheme.i
==============================================================================
--- mzscheme/Language-MzScheme/mzscheme.i (original)
+++ mzscheme/Language-MzScheme/mzscheme.i Thu Jun 10 07:30:53 2004
@@ -68,6 +68,15 @@
int SCHEME_EOFP(Scheme_Object *obj);
int SCHEME_VOIDP(Scheme_Object *obj);
+int SCHEME_LISTP(Scheme_Object *obj);
+int SCHEME_VECTORP(Scheme_Object *obj);
+
+int SCHEME_BUCKTP(Scheme_Object *obj);
+int SCHEME_HASHTP(Scheme_Object *obj);
+
+int SCHEME_INPORTP(Scheme_Object *obj);
+int SCHEME_OUTPORTP(Scheme_Object *obj);
+
char SCHEME_CHAR_VAL(Scheme_Object *obj);
int SCHEME_INT_VAL(Scheme_Object *obj);
double SCHEME_DBL_VAL(Scheme_Object *obj);
@@ -85,11 +94,6 @@
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);
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 07:30:53 2004
@@ -18,16 +18,39 @@
$env->eval(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->export('square');
-is($code->(4), 16, 'export');
+my $code = $env->lookup('square');
+isa_ok($code, 'CODE', 'to_code');
+is($code->(4), 16, '->(), scheme-lambda');
+
+is($env->eval('(square 4)'), 16, 'eval');
+is($env->apply('tree-reverse', $env->eval(q{'(a b c)})), '(((() . c) . b) . a)', 'apply');
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');
+my $hello = $env->define('perl-hello', \&hello);
+isa_ok($hello, 'CODE', 'define');
+
+my $ditto = '...env->eval';
+
+is($hello, '#<primitive:'.\&hello.'>', 'primitive name');
+is($env->eval('perl-hello'), '#<primitive:'.\&hello.'>', $ditto);
+
+is($hello->("Scheme", "Perl"), '(Hello Perl Scheme)', '->(), perl-lambda');
+is($env->eval('(perl-hello "Scheme" "Perl")'), '(Hello Perl Scheme)', $ditto);
+
+is($hello->("Scheme", "Perl")->car, 'Hello', '->car');
+is($env->eval('(car (perl-hello "Scheme" "Perl"))'), 'Hello', $ditto);
+
+is($hello->("Scheme", "Perl")->cadr, 'Perl', '->cadr');
+is($env->eval('(cadr (perl-hello "Scheme" "Perl"))'), 'Perl', $ditto);
+
+is($hello->("Scheme", "Perl")->caddr, 'Scheme', '->caddr');
+is($env->eval('(caddr (perl-hello "Scheme" "Perl"))'), 'Scheme', $ditto);
+
+1;
More information about the Rt-commit
mailing list