mirror of
https://github.com/kanaka/mal.git
synced 2024-10-26 14:22:25 +03:00
Merge pull request #439 from bjh21/bjh21-perl
Final (?) perl improvements
This commit is contained in:
Joel Martin
GitHub
commit
e4171bf638
@ -59,7 +59,7 @@
|
||||
| [Object Pascal](#object-pascal) | [Joel Martin](https://github.com/kanaka) |
|
||||
| [Objective C](#objective-c) | [Joel Martin](https://github.com/kanaka) |
|
||||
| [OCaml](#ocaml-4010) | [Chris Houser](https://github.com/chouser) |
|
||||
| [Perl](#perl-58) | [Joel Martin](https://github.com/kanaka) |
|
||||
| [Perl](#perl-5) | [Joel Martin](https://github.com/kanaka) |
|
||||
| [Perl 6](#perl-6) | [Hinrik Örn Sigurðsson](https://github.com/hinrik) |
|
||||
| [PHP](#php-53) | [Joel Martin](https://github.com/kanaka) |
|
||||
| [Picolisp](#picolisp) | [Vasilij Schneidermann](https://github.com/wasamasa) |
|
||||
@ -743,7 +743,9 @@ export PATH=`pwd`/node_modules/minimal-lisp/:$PATH
|
||||
miniMAL ./stepX_YYY
|
||||
```
|
||||
|
||||
### Perl 5.8
|
||||
### Perl 5
|
||||
|
||||
The Perl 5 implementation should work with perl 5.19.3 and later.
|
||||
|
||||
For readline line editing support, install Term::ReadLine::Perl or
|
||||
Term::ReadLine::Gnu from CPAN.
|
||||
|
||||
28
perl/README.md
Normal file
28
perl/README.md
Normal file
@ -0,0 +1,28 @@
|
||||
# Notes on the mal implementation in Perl5.
|
||||
|
||||
This implementation should work in any perl from 5.19.3 onwards.
|
||||
Earlier versions are likely to work too as long as you install a new
|
||||
List::Util. The implementation uses the experimental `switch`
|
||||
feature, which may make it vulnerable to future changes in perl.
|
||||
|
||||
Mal objects are all in subclasses of `Mal::Type`, and can be treated
|
||||
as scalar, array, or hash references as appropriate.
|
||||
|
||||
Metadata support uses `Hash::Util::FieldHash` to attach external
|
||||
metadata to objects. This means that in the metadata system imposes
|
||||
no overhead on the normal use of objects.
|
||||
|
||||
Hash-maps are slightly magical. They're keyed by the stringified
|
||||
versions of mal objects, and `Mal::Scalar` overloads stringification
|
||||
so that this works properly.
|
||||
|
||||
Tail-call optimisation uses Perl's built-in `goto &NAME` syntax for
|
||||
explicit tail calls. This allows functions defined by `fn*` to be
|
||||
implemented as functions at the Perl layer.
|
||||
|
||||
Perl's garbage-collection is based on reference counting. This means
|
||||
that reference loops will cause memory leaks, and in particular using
|
||||
`def!` to define a function will cause that function to have a
|
||||
reference to the environment it's defined in, making a small reference
|
||||
loop and hence a memory leak. This can be avoided by carefully
|
||||
undefining any function before it goes out of scope.
|
||||
16
perl/core.pm
16
perl/core.pm
@ -8,7 +8,7 @@ use List::Util qw(pairmap);
|
||||
use Time::HiRes qw(time);
|
||||
|
||||
use readline;
|
||||
use types qw(_equal_Q $nil $true $false);
|
||||
use types qw(_equal_Q thaw_key $nil $true $false);
|
||||
use reader qw(read_str);
|
||||
use printer qw(_pr_str);
|
||||
use interop qw(pl_to_mal);
|
||||
@ -49,28 +49,28 @@ sub slurp {
|
||||
|
||||
sub assoc {
|
||||
my $src_hsh = shift;
|
||||
return Mal::HashMap->new( { %$src_hsh, pairmap { $$a => $b } @_ } );
|
||||
return Mal::HashMap->new( { %$src_hsh, @_ } );
|
||||
}
|
||||
|
||||
sub dissoc {
|
||||
my $new_hsh = { %{shift @_} };
|
||||
delete @{$new_hsh}{map $$_, @_};
|
||||
delete @{$new_hsh}{@_};
|
||||
return Mal::HashMap->new($new_hsh);
|
||||
}
|
||||
|
||||
|
||||
sub get {
|
||||
my ($hsh, $key) = @_;
|
||||
return $hsh->{$$key} // $nil;
|
||||
return $hsh->{$key} // $nil;
|
||||
}
|
||||
|
||||
sub contains_Q {
|
||||
my ($hsh, $key) = @_;
|
||||
return (exists $hsh->{$$key}) ? $true : $false;
|
||||
return (exists $hsh->{$key}) ? $true : $false;
|
||||
}
|
||||
|
||||
sub mal_keys {
|
||||
my @ks = map { Mal::String->new($_) } keys %{$_[0]};
|
||||
my @ks = map { thaw_key($_) } keys %{$_[0]};
|
||||
return Mal::List->new(\@ks);
|
||||
}
|
||||
|
||||
@ -130,7 +130,7 @@ sub seq {
|
||||
} elsif ($arg->isa('Mal::Vector')) {
|
||||
return $nil unless @$arg;
|
||||
return Mal::List->new([@$arg]);
|
||||
} elsif ($arg->isa('Mal::String') && !$arg->isa('Mal::Keyword')) {
|
||||
} elsif ($arg->isa('Mal::String')) {
|
||||
return $nil if length($$arg) == 0;
|
||||
my @chars = map { Mal::String->new($_) } split(//, $$arg);
|
||||
return Mal::List->new(\@chars);
|
||||
@ -175,7 +175,7 @@ sub pl_STAR {
|
||||
'number?' => sub { $_[0]->isa('Mal::Integer') ? $true : $false },
|
||||
'symbol' => sub { Mal::Symbol->new(${$_[0]}) },
|
||||
'symbol?' => sub { $_[0]->isa('Mal::Symbol') ? $true : $false },
|
||||
'string?' => sub { $_[0]->isa('Mal::String') && !$_[0]->isa('Mal::Keyword') ? $true : $false },
|
||||
'string?' => sub { $_[0]->isa('Mal::String') ? $true : $false },
|
||||
'keyword' => sub { Mal::Keyword->new(${$_[0]}) },
|
||||
'keyword?' => sub { $_[0]->isa('Mal::Keyword') ? $true : $false },
|
||||
'fn?' => sub { $_[0]->isa('Mal::Function') ? $true : $false },
|
||||
|
||||
@ -4,6 +4,7 @@ use warnings;
|
||||
|
||||
use Exporter 'import';
|
||||
our @EXPORT_OK = qw( pl_to_mal );
|
||||
use List::Util qw(pairmap);
|
||||
use Scalar::Util qw(looks_like_number);
|
||||
|
||||
use types qw($nil);
|
||||
@ -15,11 +16,8 @@ sub pl_to_mal {
|
||||
my @arr = map {pl_to_mal($_)} @$obj;
|
||||
return Mal::List->new(\@arr);
|
||||
} elsif (/^HASH/) {
|
||||
my $hsh = {};
|
||||
foreach my $key (keys %$obj) {
|
||||
$hsh->{$key} = pl_to_mal($obj->{$key});
|
||||
}
|
||||
return Mal::HashMap->new($hsh)
|
||||
my %hsh = map { pl_to_mal($_) } %$obj;
|
||||
return Mal::HashMap->new(\%hsh)
|
||||
} else {
|
||||
if (!defined($obj)) {
|
||||
return $nil;
|
||||
|
||||
@ -5,7 +5,7 @@ use warnings;
|
||||
use Exporter 'import';
|
||||
our @EXPORT_OK = qw( _pr_str );
|
||||
|
||||
use types qw($nil $true $false);
|
||||
use types qw(thaw_key $nil $true $false);
|
||||
|
||||
use Data::Dumper;
|
||||
use List::Util qw(pairmap);
|
||||
@ -18,12 +18,12 @@ sub _pr_str {
|
||||
} elsif ($obj->isa('Mal::Vector')) {
|
||||
return '[' . join(' ', map { _pr_str($_, $_r) } @$obj) . ']';
|
||||
} elsif ($obj->isa('Mal::HashMap')) {
|
||||
return '{' . join(' ', pairmap { _pr_str(Mal::String->new($a), $_r) =>
|
||||
return '{' . join(' ', pairmap { _pr_str(thaw_key($a), $_r) =>
|
||||
_pr_str($b, $_r) } %$obj) . '}';
|
||||
} elsif ($obj->isa('Mal::Keyword')) {
|
||||
return ":$$obj";
|
||||
} elsif ($obj->isa('Mal::String')) {
|
||||
if ($$obj =~ /^\x{029e}/) {
|
||||
return ":$'";
|
||||
} elsif ($_r) {
|
||||
if ($_r) {
|
||||
my $str = $$obj;
|
||||
$str =~ s/\\/\\\\/g;
|
||||
$str =~ s/"/\\"/g;
|
||||
|
||||
@ -43,20 +43,20 @@ sub EVAL {
|
||||
}
|
||||
|
||||
# apply list
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
if (!$a0) { return $ast; }
|
||||
given ($$a0) {
|
||||
unless (@$ast) { return $ast; }
|
||||
given (${$ast->[0]}) {
|
||||
when ('def!') {
|
||||
my $res = EVAL($a2, $env);
|
||||
return $env->set($a1, $res);
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($sym, EVAL($val, $env));
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$a1) {
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($k, EVAL($v, $let_env));
|
||||
}
|
||||
return EVAL($a2, $let_env);
|
||||
return EVAL($body, $let_env);
|
||||
}
|
||||
default {
|
||||
my @el = @{eval_ast($ast, $env)};
|
||||
|
||||
@ -44,37 +44,41 @@ sub EVAL {
|
||||
}
|
||||
|
||||
# apply list
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
if (!$a0) { return $ast; }
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my $res = EVAL($a2, $env);
|
||||
return $env->set($a1, $res);
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($sym, EVAL($val, $env));
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$a1) {
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($k, EVAL($v, $let_env));
|
||||
}
|
||||
return EVAL($a2, $let_env);
|
||||
return EVAL($body, $let_env);
|
||||
}
|
||||
when ('do') {
|
||||
my $el = eval_ast($ast->rest(), $env);
|
||||
return $el->[$#$el];
|
||||
my (undef, @todo) = @$ast;
|
||||
my $el = eval_ast(Mal::List->new(\@todo), $env);
|
||||
return pop @$el;
|
||||
}
|
||||
when ('if') {
|
||||
my $cond = EVAL($a1, $env);
|
||||
my (undef, $if, $then, $else) = @$ast;
|
||||
my $cond = EVAL($if, $env);
|
||||
if ($cond eq $nil || $cond eq $false) {
|
||||
return $a3 ? EVAL($a3, $env) : $nil;
|
||||
return $else ? EVAL($else, $env) : $nil;
|
||||
} else {
|
||||
return EVAL($a2, $env);
|
||||
return EVAL($then, $env);
|
||||
}
|
||||
}
|
||||
when ('fn*') {
|
||||
my (undef, $params, $body) = @$ast;
|
||||
return Mal::Function->new(sub {
|
||||
#print "running fn*\n";
|
||||
return EVAL($a2, Mal::Env->new($env, $a1, \@_));
|
||||
return EVAL($body, Mal::Env->new($env, $params, \@_));
|
||||
});
|
||||
}
|
||||
default {
|
||||
|
||||
@ -45,40 +45,45 @@ sub EVAL {
|
||||
}
|
||||
|
||||
# apply list
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
if (!$a0) { return $ast; }
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my $res = EVAL($a2, $env);
|
||||
return $env->set($a1, $res);
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($sym, EVAL($val, $env));
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$a1) {
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($k, EVAL($v, $let_env));
|
||||
}
|
||||
@_ = ($a2, $let_env);
|
||||
@_ = ($body, $let_env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('do') {
|
||||
eval_ast($ast->slice(1, $#$ast-1), $env);
|
||||
@_ = ($ast->[$#$ast], $env);
|
||||
my (undef, @todo) = @$ast;
|
||||
my $last = pop @todo;
|
||||
eval_ast(Mal::List->new(\@todo), $env);
|
||||
@_ = ($last, $env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('if') {
|
||||
my $cond = EVAL($a1, $env);
|
||||
my (undef, $if, $then, $else) = @$ast;
|
||||
my $cond = EVAL($if, $env);
|
||||
if ($cond eq $nil || $cond eq $false) {
|
||||
@_ = ($a3 // $nil, $env);
|
||||
@_ = ($else // $nil, $env);
|
||||
} else {
|
||||
@_ = ($a2, $env);
|
||||
@_ = ($then, $env);
|
||||
}
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('fn*') {
|
||||
my (undef, $params, $body) = @$ast;
|
||||
return Mal::Function->new(sub {
|
||||
#print "running fn*\n";
|
||||
@_ = ($a2, Mal::Env->new($env, $a1, \@_));
|
||||
@_ = ($body, Mal::Env->new($env, $params, \@_));
|
||||
goto &EVAL;
|
||||
});
|
||||
}
|
||||
|
||||
@ -45,40 +45,45 @@ sub EVAL {
|
||||
}
|
||||
|
||||
# apply list
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
if (!$a0) { return $ast; }
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my $res = EVAL($a2, $env);
|
||||
return $env->set($a1, $res);
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($sym, EVAL($val, $env));
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$a1) {
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($k, EVAL($v, $let_env));
|
||||
}
|
||||
@_ = ($a2, $let_env);
|
||||
@_ = ($body, $let_env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('do') {
|
||||
eval_ast($ast->slice(1, $#$ast-1), $env);
|
||||
@_ = ($ast->[$#$ast], $env);
|
||||
my (undef, @todo) = @$ast;
|
||||
my $last = pop @todo;
|
||||
eval_ast(Mal::List->new(\@todo), $env);
|
||||
@_ = ($last, $env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('if') {
|
||||
my $cond = EVAL($a1, $env);
|
||||
my (undef, $if, $then, $else) = @$ast;
|
||||
my $cond = EVAL($if, $env);
|
||||
if ($cond eq $nil || $cond eq $false) {
|
||||
@_ = ($a3 // $nil, $env);
|
||||
@_ = ($else // $nil, $env);
|
||||
} else {
|
||||
@_ = ($a2, $env);
|
||||
@_ = ($then, $env);
|
||||
}
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('fn*') {
|
||||
my (undef, $params, $body) = @$ast;
|
||||
return Mal::Function->new(sub {
|
||||
#print "running fn*\n";
|
||||
@_ = ($a2, Mal::Env->new($env, $a1, \@_));
|
||||
@_ = ($body, Mal::Env->new($env, $params, \@_));
|
||||
goto &EVAL;
|
||||
});
|
||||
}
|
||||
|
||||
@ -68,47 +68,52 @@ sub EVAL {
|
||||
}
|
||||
|
||||
# apply list
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
if (!$a0) { return $ast; }
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my $res = EVAL($a2, $env);
|
||||
return $env->set($a1, $res);
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($sym, EVAL($val, $env));
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$a1) {
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($k, EVAL($v, $let_env));
|
||||
}
|
||||
@_ = ($a2, $let_env);
|
||||
@_ = ($body, $let_env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('quote') {
|
||||
return $a1;
|
||||
return $ast->[1];
|
||||
}
|
||||
when ('quasiquote') {
|
||||
@_ = (quasiquote($a1), $env);
|
||||
@_ = (quasiquote($ast->[1]), $env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('do') {
|
||||
eval_ast($ast->slice(1, $#$ast-1), $env);
|
||||
@_ = ($ast->[$#$ast], $env);
|
||||
my (undef, @todo) = @$ast;
|
||||
my $last = pop @todo;
|
||||
eval_ast(Mal::List->new(\@todo), $env);
|
||||
@_ = ($last, $env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('if') {
|
||||
my $cond = EVAL($a1, $env);
|
||||
my (undef, $if, $then, $else) = @$ast;
|
||||
my $cond = EVAL($if, $env);
|
||||
if ($cond eq $nil || $cond eq $false) {
|
||||
@_ = ($a3 // $nil, $env);
|
||||
@_ = ($else // $nil, $env);
|
||||
} else {
|
||||
@_ = ($a2, $env);
|
||||
@_ = ($then, $env);
|
||||
}
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('fn*') {
|
||||
my (undef, $params, $body) = @$ast;
|
||||
return Mal::Function->new(sub {
|
||||
#print "running fn*\n";
|
||||
@_ = ($a2, Mal::Env->new($env, $a1, \@_));
|
||||
@_ = ($body, Mal::Env->new($env, $params, \@_));
|
||||
goto &EVAL;
|
||||
});
|
||||
}
|
||||
|
||||
@ -97,56 +97,60 @@ sub EVAL {
|
||||
goto &eval_ast;
|
||||
}
|
||||
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
if (!$a0) { return $ast; }
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my $res = EVAL($a2, $env);
|
||||
return $env->set($a1, $res);
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($sym, EVAL($val, $env));
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$a1) {
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($k, EVAL($v, $let_env));
|
||||
}
|
||||
@_ = ($a2, $let_env);
|
||||
@_ = ($body, $let_env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('quote') {
|
||||
return $a1;
|
||||
return $ast->[1];
|
||||
}
|
||||
when ('quasiquote') {
|
||||
@_ = (quasiquote($a1), $env);
|
||||
@_ = (quasiquote($ast->[1]), $env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('defmacro!') {
|
||||
my $func = EVAL($a2, $env)->clone;
|
||||
$func = Mal::Macro->new($func);
|
||||
return $env->set($a1, $func);
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($sym, Mal::Macro->new(EVAL($val, $env)->clone));
|
||||
}
|
||||
when ('macroexpand') {
|
||||
@_ = ($a1, $env);
|
||||
return macroexpand($a1, $env);
|
||||
@_ = ($ast->[1], $env);
|
||||
goto ¯oexpand;
|
||||
}
|
||||
when ('do') {
|
||||
eval_ast($ast->slice(1, $#$ast-1), $env);
|
||||
@_ = ($ast->[$#$ast], $env);
|
||||
my (undef, @todo) = @$ast;
|
||||
my $last = pop @todo;
|
||||
eval_ast(Mal::List->new(\@todo), $env);
|
||||
@_ = ($last, $env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('if') {
|
||||
my $cond = EVAL($a1, $env);
|
||||
my (undef, $if, $then, $else) = @$ast;
|
||||
my $cond = EVAL($if, $env);
|
||||
if ($cond eq $nil || $cond eq $false) {
|
||||
@_ = ($a3 // $nil, $env);
|
||||
@_ = ($else // $nil, $env);
|
||||
} else {
|
||||
@_ = ($a2, $env);
|
||||
@_ = ($then, $env);
|
||||
}
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('fn*') {
|
||||
my (undef, $params, $body) = @$ast;
|
||||
return Mal::Function->new(sub {
|
||||
#print "running fn*\n";
|
||||
@_ = ($a2, Mal::Env->new($env, $a1, \@_));
|
||||
@_ = ($body, Mal::Env->new($env, $params, \@_));
|
||||
goto &EVAL;
|
||||
});
|
||||
}
|
||||
|
||||
@ -98,42 +98,45 @@ sub EVAL {
|
||||
goto &eval_ast;
|
||||
}
|
||||
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
if (!$a0) { return $ast; }
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my $res = EVAL($a2, $env);
|
||||
return $env->set($a1, $res);
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($sym, EVAL($val, $env));
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$a1) {
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($k, EVAL($v, $let_env));
|
||||
}
|
||||
@_ = ($a2, $let_env);
|
||||
@_ = ($body, $let_env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('quote') {
|
||||
return $a1;
|
||||
return $ast->[1];
|
||||
}
|
||||
when ('quasiquote') {
|
||||
@_ = (quasiquote($a1), $env);
|
||||
@_ = (quasiquote($ast->[1]), $env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('defmacro!') {
|
||||
my $func = EVAL($a2, $env)->clone;
|
||||
$func = Mal::Macro->new($func);
|
||||
return $env->set($a1, $func);
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($sym, Mal::Macro->new(EVAL($val, $env)->clone));
|
||||
}
|
||||
when ('macroexpand') {
|
||||
return macroexpand($a1, $env);
|
||||
@_ = ($ast->[1], $env);
|
||||
goto ¯oexpand;
|
||||
}
|
||||
when ('try*') {
|
||||
my (undef, $try, $catch) = @$ast;
|
||||
local $@;
|
||||
my $ret = eval { EVAL($a1, $env) };
|
||||
my $ret = eval { EVAL($try, $env) };
|
||||
return $ret unless $@;
|
||||
if ($a2 && ${$a2->[0]} eq 'catch*') {
|
||||
if ($catch && ${$catch->[0]} eq 'catch*') {
|
||||
my (undef, $binding, $body) = @$catch;
|
||||
my $exc;
|
||||
if (defined(blessed $@) && $@->isa('Mal::Type')) {
|
||||
$exc = $@;
|
||||
@ -141,31 +144,35 @@ sub EVAL {
|
||||
chomp(my $msg = $@);
|
||||
$exc = Mal::String->new($msg);
|
||||
}
|
||||
my $catch_env = Mal::Env->new($env, [$a2->[1]], [$exc]);
|
||||
@_ = ($a2->[2], $catch_env);
|
||||
my $catch_env = Mal::Env->new($env, [$binding], [$exc]);
|
||||
@_ = ($body, $catch_env);
|
||||
goto &EVAL;
|
||||
} else {
|
||||
die $@;
|
||||
}
|
||||
}
|
||||
when ('do') {
|
||||
eval_ast($ast->slice(1, $#$ast-1), $env);
|
||||
@_ = ($ast->[$#$ast], $env);
|
||||
my (undef, @todo) = @$ast;
|
||||
my $last = pop @todo;
|
||||
eval_ast(Mal::List->new(\@todo), $env);
|
||||
@_ = ($last, $env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('if') {
|
||||
my $cond = EVAL($a1, $env);
|
||||
my (undef, $if, $then, $else) = @$ast;
|
||||
my $cond = EVAL($if, $env);
|
||||
if ($cond eq $nil || $cond eq $false) {
|
||||
@_ = ($a3 // $nil, $env);
|
||||
@_ = ($else // $nil, $env);
|
||||
} else {
|
||||
@_ = ($a2, $env);
|
||||
@_ = ($then, $env);
|
||||
}
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('fn*') {
|
||||
my (undef, $params, $body) = @$ast;
|
||||
return Mal::Function->new(sub {
|
||||
#print "running fn*\n";
|
||||
@_ = ($a2, Mal::Env->new($env, $a1, \@_));
|
||||
@_ = ($body, Mal::Env->new($env, $params, \@_));
|
||||
goto &EVAL;
|
||||
});
|
||||
}
|
||||
|
||||
@ -97,42 +97,45 @@ sub EVAL {
|
||||
goto &eval_ast;
|
||||
}
|
||||
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
if (!$a0) { return $ast; }
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my $res = EVAL($a2, $env);
|
||||
return $env->set($a1, $res);
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($sym, EVAL($val, $env));
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$a1) {
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($k, EVAL($v, $let_env));
|
||||
}
|
||||
@_ = ($a2, $let_env);
|
||||
@_ = ($body, $let_env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('quote') {
|
||||
return $a1;
|
||||
return $ast->[1];
|
||||
}
|
||||
when ('quasiquote') {
|
||||
@_ = (quasiquote($a1), $env);
|
||||
@_ = (quasiquote($ast->[1]), $env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('defmacro!') {
|
||||
my $func = EVAL($a2, $env)->clone;
|
||||
$func = Mal::Macro->new($func);
|
||||
return $env->set($a1, $func);
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($sym, Mal::Macro->new(EVAL($val, $env)->clone));
|
||||
}
|
||||
when ('macroexpand') {
|
||||
return macroexpand($a1, $env);
|
||||
@_ = ($ast->[1], $env);
|
||||
goto ¯oexpand;
|
||||
}
|
||||
when ('try*') {
|
||||
my (undef, $try, $catch) = @$ast;
|
||||
local $@;
|
||||
my $ret = eval { EVAL($a1, $env) };
|
||||
my $ret = eval { EVAL($try, $env) };
|
||||
return $ret unless $@;
|
||||
if ($a2 && ${$a2->[0]} eq 'catch*') {
|
||||
if ($catch && ${$catch->[0]} eq 'catch*') {
|
||||
my (undef, $binding, $body) = @$catch;
|
||||
my $exc;
|
||||
if (defined(blessed $@) && $@->isa('Mal::Type')) {
|
||||
$exc = $@;
|
||||
@ -140,31 +143,35 @@ sub EVAL {
|
||||
chomp(my $msg = $@);
|
||||
$exc = Mal::String->new($msg);
|
||||
}
|
||||
my $catch_env = Mal::Env->new($env, [$a2->[1]], [$exc]);
|
||||
@_ = ($a2->[2], $catch_env);
|
||||
my $catch_env = Mal::Env->new($env, [$binding], [$exc]);
|
||||
@_ = ($body, $catch_env);
|
||||
goto &EVAL;
|
||||
} else {
|
||||
die $@;
|
||||
}
|
||||
}
|
||||
when ('do') {
|
||||
eval_ast($ast->slice(1, $#$ast-1), $env);
|
||||
@_ = ($ast->[$#$ast], $env);
|
||||
my (undef, @todo) = @$ast;
|
||||
my $last = pop @todo;
|
||||
eval_ast(Mal::List->new(\@todo), $env);
|
||||
@_ = ($last, $env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('if') {
|
||||
my $cond = EVAL($a1, $env);
|
||||
my (undef, $if, $then, $else) = @$ast;
|
||||
my $cond = EVAL($if, $env);
|
||||
if ($cond eq $nil || $cond eq $false) {
|
||||
@_ = ($a3 // $nil, $env);
|
||||
@_ = ($else // $nil, $env);
|
||||
} else {
|
||||
@_ = ($a2, $env);
|
||||
@_ = ($then, $env);
|
||||
}
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('fn*') {
|
||||
my (undef, $params, $body) = @$ast;
|
||||
return Mal::Function->new(sub {
|
||||
#print "running fn*\n";
|
||||
@_ = ($a2, Mal::Env->new($env, $a1, \@_));
|
||||
@_ = ($body, Mal::Env->new($env, $params, \@_));
|
||||
goto &EVAL;
|
||||
});
|
||||
}
|
||||
|
||||
@ -4,7 +4,7 @@ use warnings;
|
||||
|
||||
use Data::Dumper;
|
||||
use Exporter 'import';
|
||||
our @EXPORT_OK = qw(_equal_Q
|
||||
our @EXPORT_OK = qw(_equal_Q thaw_key
|
||||
$nil $true $false);
|
||||
|
||||
# General functions
|
||||
@ -60,9 +60,22 @@ sub _equal_Q {
|
||||
{
|
||||
package Mal::Scalar;
|
||||
use parent -norequire, 'Mal::Type';
|
||||
# Overload stringification so that its result is something
|
||||
# suitable for use as a hash-map key. The important thing here is
|
||||
# that strings and keywords are distinct: support for other kinds
|
||||
# of scalar is a bonus.
|
||||
use overload '""' => sub { my $self = shift; ref($self) . " " . $$self },
|
||||
fallback => 1;
|
||||
sub new { my ($class, $value) = @_; bless \$value, $class }
|
||||
}
|
||||
|
||||
# This function converts hash-map keys back into full objects
|
||||
|
||||
sub thaw_key ($) {
|
||||
my ($class, $value) = split(/ /, $_[0], 2);
|
||||
return $class->new($value);
|
||||
}
|
||||
|
||||
{
|
||||
package Mal::Nil;
|
||||
use parent -norequire, 'Mal::Scalar';
|
||||
@ -99,14 +112,12 @@ our $false = Mal::False->new('false');
|
||||
{
|
||||
package Mal::String;
|
||||
use parent -norequire, 'Mal::Scalar';
|
||||
# "isa" can distinguish keywords from other strings.
|
||||
sub isa {
|
||||
my $self = shift;
|
||||
return 1 if ($_[0] eq 'Mal::Keyword' && $$self =~ /^\x{029e}/);
|
||||
return $self->SUPER::isa(@_);
|
||||
}
|
||||
# Pseudo-constructor for making keywords.
|
||||
sub Mal::Keyword::new { shift; Mal::String->new("\x{029e}" . $_[0]) }
|
||||
}
|
||||
|
||||
|
||||
{
|
||||
package Mal::Keyword;
|
||||
use parent -norequire, 'Mal::Scalar';
|
||||
}
|
||||
|
||||
|
||||
@ -117,7 +128,6 @@ our $false = Mal::False->new('false');
|
||||
use parent -norequire, 'Mal::Type';
|
||||
sub new { my $class = shift; bless $_[0], $class }
|
||||
sub rest { my $arr = $_[0]; Mal::List->new([@$arr[1..$#$arr]]); }
|
||||
sub slice { my $arr = $_[0]; Mal::List->new([@$arr[$_[1]..$_[2]]]); }
|
||||
sub clone { my $self = shift; ref($self)->new([@$self]) }
|
||||
}
|
||||
|
||||
@ -147,7 +157,7 @@ our $false = Mal::False->new('false');
|
||||
sub new {
|
||||
my ($class, $src) = @_;
|
||||
if (reftype($src) eq 'ARRAY') {
|
||||
$src = {pairmap { $$a => $b } @$src};
|
||||
$src = {@$src};
|
||||
}
|
||||
return bless $src, $class;
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user