mirror of
https://github.com/kanaka/mal.git
synced 2024-10-26 14:22:25 +03:00
Perl: add vector, hash-map, metadata, atom support. TCO let*
- Changes all collections to be one level of inderection where the top level is always a hash containing 'meta' and 'val'.
This commit is contained in:
parent
85cc53f35b
commit
89bd4de1e2
@ -5,7 +5,7 @@ All:
|
||||
- hash-map with space in key string (make)
|
||||
- keyword type
|
||||
- gensym reader inside quasiquote
|
||||
- can let* and quasiquote be TCO'd ?
|
||||
- quasiquote be TCO'd ?
|
||||
|
||||
- per impl tests for step5_tco, step9_interop (if possible)
|
||||
- regular expression matching in runtest
|
||||
@ -14,6 +14,8 @@ All:
|
||||
- Break out impl eval into step0.5
|
||||
- Fix quasiquoting of vectors
|
||||
|
||||
- TCO for let*
|
||||
|
||||
---------------------------------------------
|
||||
|
||||
Bash:
|
||||
|
@ -78,8 +78,6 @@ Step Notes:
|
||||
- eval_ast:
|
||||
- if symbol, return value of looking up in env
|
||||
- if list, eval each item, return new list
|
||||
- if vector support, eval each item, return new vector
|
||||
- if hash_map support, eval each value, return new hash_map
|
||||
- otherwise, just return unchanged ast
|
||||
- EVAL/apply:
|
||||
- if not a list, call eval_ast
|
||||
@ -87,6 +85,12 @@ Step Notes:
|
||||
- repl_env as simple one level assoc. array (or hash_map)
|
||||
- store function as hash_map value
|
||||
|
||||
- vectors
|
||||
- eval each item, return new vector
|
||||
|
||||
- hash-maps
|
||||
- eval each value, return new hash_map
|
||||
|
||||
- step3_env
|
||||
- types module:
|
||||
- may need function type if HashMap is strongly typed (e.g. Java)
|
||||
@ -195,6 +199,8 @@ Step Notes:
|
||||
- Extra defintions needed for self-hosting
|
||||
- core module:
|
||||
- symbol?, sequential? (if not already)
|
||||
- vector, vector?
|
||||
|
||||
|
||||
- Other misc:
|
||||
- conj function
|
||||
@ -202,14 +208,16 @@ Step Notes:
|
||||
- atoms
|
||||
- reader module:
|
||||
- @a reader macro -> (deref a)
|
||||
- types module:
|
||||
- core module:
|
||||
- pr_str case
|
||||
- atom type, atom, atom?, deref, reset!, swap!
|
||||
|
||||
- metadata
|
||||
- types module:
|
||||
- support meta property on symbols, hash-maps, lists, vectors,
|
||||
functions, atoms
|
||||
- add with-meta, meta functions
|
||||
- reader module:
|
||||
- ^ reader macro reads ^meta obj -> (with-meta obj meta)
|
||||
- types module:
|
||||
- support meta property on collections: lists, vectors,
|
||||
hash-maps, functions, atoms
|
||||
- clone/copy of collections
|
||||
- core module:
|
||||
- add with-meta, meta functions
|
||||
|
167
perl/core.pm
167
perl/core.pm
@ -4,10 +4,10 @@ use warnings FATAL => qw(all);
|
||||
use Exporter 'import';
|
||||
our @EXPORT_OK = qw($core_ns);
|
||||
|
||||
use readline qw(readline);
|
||||
use types qw(_sequential_Q _equal_Q $nil $true $false
|
||||
_symbol_Q _nil_Q _true_Q _false_Q _list_Q
|
||||
_hash_map _hash_map_Q _assoc_BANG _dissoc_BANG);
|
||||
use readline;
|
||||
use types qw(_sequential_Q _equal_Q _clone $nil $true $false
|
||||
_symbol_Q _nil_Q _true_Q _false_Q _list_Q _vector_Q
|
||||
_hash_map _hash_map_Q _assoc_BANG _dissoc_BANG _atom_Q);
|
||||
use reader qw(read_str);
|
||||
use printer qw(_pr_str);
|
||||
|
||||
@ -16,32 +16,32 @@ use Data::Dumper;
|
||||
# String functions
|
||||
|
||||
sub pr_str {
|
||||
return String->new(join(" ", map {_pr_str($_, 1)} @{$_[0]}));
|
||||
return String->new(join(" ", map {_pr_str($_, 1)} @{$_[0]->{val}}));
|
||||
}
|
||||
|
||||
sub str {
|
||||
return String->new(join("", map {_pr_str($_, 0)} @{$_[0]}));
|
||||
return String->new(join("", map {_pr_str($_, 0)} @{$_[0]->{val}}));
|
||||
}
|
||||
|
||||
sub prn {
|
||||
print join(" ", map {_pr_str($_, 1)} @{$_[0]}) . "\n";
|
||||
print join(" ", map {_pr_str($_, 1)} @{$_[0]->{val}}) . "\n";
|
||||
return $nil
|
||||
}
|
||||
|
||||
sub println {
|
||||
print join(" ", map {_pr_str($_, 0)} @{$_[0]}) . "\n";
|
||||
print join(" ", map {_pr_str($_, 0)} @{$_[0]->{val}}) . "\n";
|
||||
return $nil
|
||||
}
|
||||
|
||||
sub mal_readline {
|
||||
my $line = readline(${$_[0]});
|
||||
return $line ? String->new($line) : $nil;
|
||||
my $line = readline::mal_readline(${$_[0]});
|
||||
return defined $line ? String->new($line) : $nil;
|
||||
}
|
||||
|
||||
sub slurp {
|
||||
my ($fname) = ${$_[0]};
|
||||
open my $F, '<', $fname or die "error opening '$fname'";
|
||||
my $data = do { local $/; <$F> };
|
||||
my $fname = ${$_[0]};
|
||||
open(my $fh, '<', $fname) or die "error opening '$fname'";
|
||||
my $data = do { local $/; <$fh> };
|
||||
String->new($data)
|
||||
}
|
||||
|
||||
@ -49,13 +49,13 @@ sub slurp {
|
||||
|
||||
sub assoc {
|
||||
my $src_hsh = shift;
|
||||
my $new_hsh = { %$src_hsh };
|
||||
my $new_hsh = { %{$src_hsh->{val}} };
|
||||
return _assoc_BANG($new_hsh, @_);
|
||||
}
|
||||
|
||||
sub dissoc {
|
||||
my $src_hsh = shift;
|
||||
my $new_hsh = { %$src_hsh };
|
||||
my $new_hsh = { %{$src_hsh->{val}} };
|
||||
return _dissoc_BANG($new_hsh, @_);
|
||||
}
|
||||
|
||||
@ -63,22 +63,22 @@ sub dissoc {
|
||||
sub get {
|
||||
my ($hsh, $key) = @_;
|
||||
return $nil if $hsh eq $nil;
|
||||
return exists $hsh->{$$key} ? $hsh->{$$key} : $nil;
|
||||
return exists $hsh->{val}->{$$key} ? $hsh->{val}->{$$key} : $nil;
|
||||
}
|
||||
|
||||
sub contains_Q {
|
||||
my ($hsh, $key) = @_;
|
||||
return $nil if $hsh eq $false;
|
||||
return (exists $hsh->{$$key}) ? $true : $false;
|
||||
return (exists $hsh->{val}->{$$key}) ? $true : $false;
|
||||
}
|
||||
|
||||
sub mal_keys {
|
||||
my @ks = map { String->new($_) } keys %{$_[0]};
|
||||
my @ks = map { String->new($_) } keys %{$_[0]->{val}};
|
||||
return List->new(\@ks);
|
||||
}
|
||||
|
||||
sub mal_vals {
|
||||
my @vs = values %{$_[0]};
|
||||
my @vs = values %{$_[0]->{val}};
|
||||
return List->new(\@vs);
|
||||
}
|
||||
|
||||
@ -88,30 +88,30 @@ sub mal_vals {
|
||||
sub cons {
|
||||
my ($a, $b) = @_;
|
||||
my @new_arr = @{[$a]};
|
||||
push @new_arr, @$b;
|
||||
push @new_arr, @{$b->{val}};
|
||||
List->new(\@new_arr);
|
||||
}
|
||||
|
||||
sub concat {
|
||||
if (scalar(@_) == 0) { return List->new([]); }
|
||||
my ($a) = shift;
|
||||
my @new_arr = @{$a};
|
||||
map { push @new_arr, @$_ } @_;
|
||||
my @new_arr = @{$a->{val}};
|
||||
map { push @new_arr, @{$_->{val}} } @_;
|
||||
List->new(\@new_arr);
|
||||
}
|
||||
|
||||
sub nth { my ($seq,$i) = @_; return scalar(@$seq) > $i ? $seq->[$i] : $nil; }
|
||||
sub nth { my ($seq,$i) = @_; return scalar(@{$seq->{val}}) > $i ? $seq->nth($i) : $nil; }
|
||||
|
||||
sub first { my ($seq) = @_; return scalar(@$seq) > 0 ? $seq->[0] : $nil; }
|
||||
sub first { my ($seq) = @_; return scalar(@{$seq->{val}}) > 0 ? $seq->nth(0) : $nil; }
|
||||
|
||||
sub rest { return $_[0]->rest(); }
|
||||
|
||||
sub apply {
|
||||
my @all_args = @{$_[0]};
|
||||
my @all_args = @{$_[0]->{val}};
|
||||
my $f = $all_args[0];
|
||||
my @apply_args = @all_args[1..$#all_args];
|
||||
my @args = @apply_args[0..$#apply_args-1];
|
||||
push @args, @{$apply_args[$#apply_args]};
|
||||
push @args, @{$apply_args[$#apply_args]->{val}};
|
||||
if ((ref $f) =~ /^Function/) {
|
||||
return $f->apply(List->new(\@args));
|
||||
} else {
|
||||
@ -123,60 +123,99 @@ sub mal_map {
|
||||
my $f = shift;
|
||||
my @arr;
|
||||
if ((ref $f) =~ /^Function/) {
|
||||
@arr = map { $f->apply(List->new([$_])) } @{$_[0]};
|
||||
@arr = map { $f->apply(List->new([$_])) } @{$_[0]->{val}};
|
||||
} else {
|
||||
@arr = map { &{ $f}(List->new([$_])) } @{$_[0]};
|
||||
@arr = map { &{ $f}(List->new([$_])) } @{$_[0]->{val}};
|
||||
}
|
||||
return List->new(\@arr);
|
||||
}
|
||||
|
||||
|
||||
# Metadata functions
|
||||
sub with_meta {
|
||||
my $new_obj = _clone($_[0]);
|
||||
$new_obj->{meta} = $_[1];
|
||||
return $new_obj;
|
||||
}
|
||||
|
||||
sub meta {
|
||||
if ((ref $_[0]) && !((ref $_[0]) =~ /^CODE/)) {
|
||||
return $_[0]->{meta};
|
||||
} else {
|
||||
return $nil;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Atom functions
|
||||
sub swap_BANG {
|
||||
my ($atm,$f,@args) = @_;
|
||||
unshift @args, $atm->{val};
|
||||
if ((ref $f) =~ /^Function/) {
|
||||
return $atm->{val} = $f->apply(List->new(\@args));
|
||||
} else {
|
||||
return $atm->{val} = &{ $f }(List->new(\@args));
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
our $core_ns = {
|
||||
'=' => sub { _equal_Q($_[0][0], $_[0][1]) ? $true : $false },
|
||||
'throw' => sub { die $_[0][0] },
|
||||
'nil?' => sub { _nil_Q($_[0][0]) ? $true : $false },
|
||||
'true?' => sub { _true_Q($_[0][0]) ? $true : $false },
|
||||
'false?' => sub { _false_Q($_[0][0]) ? $true : $false },
|
||||
'symbol?' => sub { _symbol_Q($_[0][0]) ? $true : $false },
|
||||
'=' => sub { _equal_Q($_[0]->nth(0), $_[0]->nth(1)) ? $true : $false },
|
||||
'throw' => sub { die $_[0]->nth(0) },
|
||||
'nil?' => sub { _nil_Q($_[0]->nth(0)) ? $true : $false },
|
||||
'true?' => sub { _true_Q($_[0]->nth(0)) ? $true : $false },
|
||||
'false?' => sub { _false_Q($_[0]->nth(0)) ? $true : $false },
|
||||
'symbol?' => sub { _symbol_Q($_[0]->nth(0)) ? $true : $false },
|
||||
|
||||
'pr-str' => sub { pr_str($_[0]) },
|
||||
'str' => sub { str($_[0]) },
|
||||
'prn' => sub { prn($_[0]) },
|
||||
'println' => sub { println($_[0]) },
|
||||
'readline' => sub { mal_readline($_[0][0]) },
|
||||
'read-string' => sub { read_str(${$_[0][0]}) },
|
||||
'slurp' => sub { slurp($_[0][0]) },
|
||||
'<' => sub { ${$_[0][0]} < ${$_[0][1]} ? $true : $false },
|
||||
'<=' => sub { ${$_[0][0]} <= ${$_[0][1]} ? $true : $false },
|
||||
'>' => sub { ${$_[0][0]} > ${$_[0][1]} ? $true : $false },
|
||||
'>=' => sub { ${$_[0][0]} >= ${$_[0][1]} ? $true : $false },
|
||||
'+' => sub { Integer->new(${$_[0][0]} + ${$_[0][1]})},
|
||||
'-' => sub { Integer->new(${$_[0][0]} - ${$_[0][1]})},
|
||||
'*' => sub { Integer->new(${$_[0][0]} * ${$_[0][1]})},
|
||||
'/' => sub { Integer->new(${$_[0][0]} / ${$_[0][1]})},
|
||||
'readline' => sub { mal_readline($_[0]->nth(0)) },
|
||||
'read-string' => sub { read_str(${$_[0]->nth(0)}) },
|
||||
'slurp' => sub { slurp($_[0]->nth(0)) },
|
||||
'<' => sub { ${$_[0]->nth(0)} < ${$_[0]->nth(1)} ? $true : $false },
|
||||
'<=' => sub { ${$_[0]->nth(0)} <= ${$_[0]->nth(1)} ? $true : $false },
|
||||
'>' => sub { ${$_[0]->nth(0)} > ${$_[0]->nth(1)} ? $true : $false },
|
||||
'>=' => sub { ${$_[0]->nth(0)} >= ${$_[0]->nth(1)} ? $true : $false },
|
||||
'+' => sub { Integer->new(${$_[0]->nth(0)} + ${$_[0]->nth(1)}) },
|
||||
'-' => sub { Integer->new(${$_[0]->nth(0)} - ${$_[0]->nth(1)}) },
|
||||
'*' => sub { Integer->new(${$_[0]->nth(0)} * ${$_[0]->nth(1)}) },
|
||||
'/' => sub { Integer->new(${$_[0]->nth(0)} / ${$_[0]->nth(1)}) },
|
||||
|
||||
'list' => sub { $_[0] },
|
||||
'list?' => sub { _list_Q($_[0][0]) ? $true : $false },
|
||||
'hash-map' => sub { _hash_map(@{$_[0]}) },
|
||||
'map?' => sub { _hash_map_Q($_[0][0]) ? $true : $false },
|
||||
'assoc' => sub { assoc(@{$_[0]}) },
|
||||
'dissoc' => sub { dissoc(@{$_[0]}) },
|
||||
'get' => sub { get($_[0][0],$_[0][1]) },
|
||||
'contains?' => sub { contains_Q($_[0][0],$_[0][1]) },
|
||||
'keys' => sub { mal_keys(@{$_[0]}) },
|
||||
'vals' => sub { mal_vals(@{$_[0]}) },
|
||||
'list' => sub { List->new($_[0]->{val}) },
|
||||
'list?' => sub { _list_Q($_[0]->nth(0)) ? $true : $false },
|
||||
'vector' => sub { Vector->new($_[0]->{val}) },
|
||||
'vector?' => sub { _vector_Q($_[0]->nth(0)) ? $true : $false },
|
||||
'hash-map' => sub { _hash_map(@{$_[0]->{val}}) },
|
||||
'map?' => sub { _hash_map_Q($_[0]->nth(0)) ? $true : $false },
|
||||
'assoc' => sub { assoc(@{$_[0]->{val}}) },
|
||||
'dissoc' => sub { dissoc(@{$_[0]->{val}}) },
|
||||
'get' => sub { get($_[0]->nth(0),$_[0]->nth(1)) },
|
||||
'contains?' => sub { contains_Q($_[0]->nth(0),$_[0]->nth(1)) },
|
||||
'keys' => sub { mal_keys(@{$_[0]->{val}}) },
|
||||
'vals' => sub { mal_vals(@{$_[0]->{val}}) },
|
||||
|
||||
'sequential?' => sub { _sequential_Q($_[0][0]) ? $true : $false },
|
||||
'nth' => sub { nth($_[0][0], ${$_[0][1]}) },
|
||||
'first' => sub { first($_[0][0]) },
|
||||
'rest' => sub { rest($_[0][0]) },
|
||||
'cons' => sub { cons($_[0][0], $_[0][1]) },
|
||||
'concat' => sub { concat(@{$_[0]}) },
|
||||
'empty?' => sub { scalar(@{$_[0][0]}) == 0 ? $true : $false },
|
||||
'count' => sub { Integer->new(scalar(@{$_[0][0]})) },
|
||||
'sequential?' => sub { _sequential_Q($_[0]->nth(0)) ? $true : $false },
|
||||
'nth' => sub { nth($_[0]->nth(0), ${$_[0]->nth(1)}) },
|
||||
'first' => sub { first($_[0]->nth(0)) },
|
||||
'rest' => sub { rest($_[0]->nth(0)) },
|
||||
'cons' => sub { cons($_[0]->nth(0), $_[0]->nth(1)) },
|
||||
'concat' => sub { concat(@{$_[0]->{val}}) },
|
||||
'empty?' => sub { scalar(@{$_[0]->nth(0)->{val}}) == 0 ? $true : $false },
|
||||
'count' => sub { Integer->new(scalar(@{$_[0]->nth(0)->{val}})) },
|
||||
'apply' => sub { apply($_[0]) },
|
||||
'map' => sub { mal_map($_[0][0], $_[0][1]) },
|
||||
'map' => sub { mal_map($_[0]->nth(0), $_[0]->nth(1)) },
|
||||
'conj' => sub { die "not implemented\n"; },
|
||||
|
||||
'with-meta' => sub { with_meta($_[0]->nth(0), $_[0]->nth(1)) },
|
||||
'meta' => sub { meta($_[0]->nth(0)) },
|
||||
'atom' => sub { Atom->new($_[0]->nth(0)) },
|
||||
'atom?' => sub { _atom_Q($_[0]->nth(0)) ? $true : $false },
|
||||
'deref' => sub { $_[0]->nth(0)->{val} },
|
||||
'reset!' => sub { $_[0]->nth(0)->{val} = $_[0]->nth(1) },
|
||||
'swap!' => sub { swap_BANG(@{$_[0]->{val}}) },
|
||||
};
|
||||
|
||||
1;
|
||||
|
12
perl/env.pm
12
perl/env.pm
@ -4,23 +4,23 @@ use strict;
|
||||
use warnings;
|
||||
use Exporter 'import';
|
||||
|
||||
use Data::Dumper;
|
||||
|
||||
{
|
||||
package Env;
|
||||
use Data::Dumper;
|
||||
sub new {
|
||||
my ($class,$outer,$binds,$exprs) = @_;
|
||||
my $data = { __outer__ => $outer };
|
||||
if ($binds) {
|
||||
for (my $i=0; $i<scalar(@{$binds}); $i++) {
|
||||
if (${$binds->[$i]} eq "&") {
|
||||
for (my $i=0; $i<scalar(@{$binds->{val}}); $i++) {
|
||||
if (${$binds->nth($i)} eq "&") {
|
||||
# variable length arguments
|
||||
my @earr = @$exprs; # get the array
|
||||
my @earr = @{$exprs->{val}}; # get the array
|
||||
my @new_arr = @earr[$i..$#earr]; # slice it
|
||||
$data->{${$binds->[$i+1]}} = List->new(\@new_arr);
|
||||
$data->{${$binds->nth($i+1)}} = List->new(\@new_arr);
|
||||
last;
|
||||
} else {
|
||||
$data->{${$binds->[$i]}} = $exprs->[$i];
|
||||
$data->{${$binds->nth($i)}} = $exprs->nth($i);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
@ -7,21 +7,23 @@ our @EXPORT_OK = qw( _pr_str );
|
||||
|
||||
use types qw($nil $true $false);
|
||||
|
||||
use Data::Dumper;
|
||||
|
||||
sub _pr_str {
|
||||
my($obj, $print_readably) = @_;
|
||||
my($_r) = (defined $print_readably) ? $print_readably : 1;
|
||||
given (ref $obj) {
|
||||
when(/^List/) {
|
||||
return '(' . join(' ', map {_pr_str($_, $_r)} @$obj) . ')';
|
||||
return '(' . join(' ', map {_pr_str($_, $_r)} @{$obj->{val}}) . ')';
|
||||
}
|
||||
when(/^Vector/) {
|
||||
return '[' . join(' ', map {_pr_str($_, $_r)} @$obj) . ']';
|
||||
return '[' . join(' ', map {_pr_str($_, $_r)} @{$obj->{val}}) . ']';
|
||||
}
|
||||
when(/^HashMap/) {
|
||||
my @elems = ();
|
||||
foreach my $key (keys %$obj) {
|
||||
foreach my $key (keys $obj->{val}) {
|
||||
push(@elems, _pr_str(String->new($key), $_r));
|
||||
push(@elems, _pr_str($obj->{$key}, $_r));
|
||||
push(@elems, _pr_str($obj->{val}->{$key}, $_r));
|
||||
}
|
||||
|
||||
return '{' . join(' ', @elems) . '}';
|
||||
@ -41,6 +43,9 @@ sub _pr_str {
|
||||
return '<fn* ' . _pr_str($obj->{params}) .
|
||||
' ' . _pr_str($obj->{ast}) . '>';
|
||||
}
|
||||
when(/^Atom/) {
|
||||
return '(atom ' . _pr_str($obj->{val}) . ")";
|
||||
}
|
||||
when(/^CODE/) { return '<builtin_fn* ' . $obj . '>'; }
|
||||
default { return $$obj; }
|
||||
}
|
||||
|
@ -81,6 +81,12 @@ sub read_form {
|
||||
read_form($rdr)]) }
|
||||
when('~@') { $rdr->next(); List->new([Symbol->new('splice-unquote'),
|
||||
read_form($rdr)]) }
|
||||
when('^') { $rdr->next(); my $meta = read_form($rdr);
|
||||
List->new([Symbol->new('with-meta'),
|
||||
read_form($rdr), $meta]) }
|
||||
when('@') { $rdr->next(); List->new([Symbol->new('deref'),
|
||||
read_form($rdr)]) }
|
||||
|
||||
when(')') { die "unexpected ')'" }
|
||||
when('(') { return read_list($rdr, 'List') }
|
||||
when(']') { die "unexpected ']'" }
|
||||
@ -94,7 +100,8 @@ sub read_form {
|
||||
sub read_str {
|
||||
my($str) = @_;
|
||||
my @tokens = tokenize($str);
|
||||
#print join(" / ", @tokens) . "\n";
|
||||
#print "tokens: " . Dumper(\@tokens);
|
||||
if (scalar(@tokens) == 0) { die BlankException->new(); }
|
||||
return read_form(Reader->new(\@tokens));
|
||||
}
|
||||
|
||||
|
@ -6,7 +6,7 @@ package readline;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Exporter 'import';
|
||||
our @EXPORT_OK = qw( readline );
|
||||
our @EXPORT_OK = qw( mal_readline );
|
||||
|
||||
use Term::ReadLine;
|
||||
|
||||
@ -16,7 +16,7 @@ $_rl->ornaments(0);
|
||||
my $OUT = $_rl->OUT || \*STDOUT;
|
||||
my $_history_loaded = 0;
|
||||
|
||||
sub readline {
|
||||
sub mal_readline {
|
||||
my($prompt) = @_;
|
||||
my $line = undef;
|
||||
if (! $_history_loaded) {
|
||||
|
@ -1,6 +1,6 @@
|
||||
use strict;
|
||||
use warnings FATAL => qw(all);
|
||||
use readline qw(readline);
|
||||
use readline qw(mal_readline);
|
||||
use feature qw(switch);
|
||||
|
||||
use reader;
|
||||
@ -31,15 +31,26 @@ sub REP {
|
||||
}
|
||||
|
||||
while (1) {
|
||||
my $line = readline("user> ");
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
};
|
||||
if (my $err = $@) {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
given (ref $err) {
|
||||
when (/^BlankException/) {
|
||||
# ignore and continue
|
||||
}
|
||||
default {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
}
|
||||
};
|
||||
};
|
||||
}
|
||||
|
@ -1,9 +1,10 @@
|
||||
use strict;
|
||||
use warnings FATAL => qw(all);
|
||||
use readline qw(readline);
|
||||
use readline qw(mal_readline);
|
||||
use feature qw(switch);
|
||||
use Data::Dumper;
|
||||
|
||||
use types qw(_list_Q);
|
||||
use reader;
|
||||
use printer;
|
||||
|
||||
@ -25,9 +26,20 @@ sub eval_ast {
|
||||
}
|
||||
}
|
||||
when (/^List/) {
|
||||
my @lst = map {EVAL($_, $env)} @$ast;
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return List->new(\@lst);
|
||||
}
|
||||
when (/^Vector/) {
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return Vector->new(\@lst);
|
||||
}
|
||||
when (/^HashMap/) {
|
||||
my $new_hm = {};
|
||||
foreach my $k (keys($ast->{val})) {
|
||||
$new_hm->{$k} = EVAL($ast->get($k), $env);
|
||||
}
|
||||
return HashMap->new($new_hm);
|
||||
}
|
||||
default {
|
||||
return $ast;
|
||||
}
|
||||
@ -37,13 +49,13 @@ sub eval_ast {
|
||||
sub EVAL {
|
||||
my($ast, $env) = @_;
|
||||
#print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
if (! ((ref $ast) =~ /^List/)) {
|
||||
if (! _list_Q($ast)) {
|
||||
return eval_ast($ast, $env);
|
||||
}
|
||||
|
||||
# apply list
|
||||
my $el = eval_ast($ast, $env);
|
||||
my $f = $el->[0];
|
||||
my $f = $el->nth(0);
|
||||
return &{ $f }($el->rest());
|
||||
}
|
||||
|
||||
@ -60,21 +72,32 @@ sub REP {
|
||||
return PRINT(EVAL(READ($str), $repl_env));
|
||||
}
|
||||
|
||||
$repl_env->{'+'} = sub { Integer->new(${$_[0][0]} + ${$_[0][1]}) };
|
||||
$repl_env->{'-'} = sub { Integer->new(${$_[0][0]} - ${$_[0][1]}) };
|
||||
$repl_env->{'*'} = sub { Integer->new(${$_[0][0]} * ${$_[0][1]}) };
|
||||
$repl_env->{'/'} = sub { Integer->new(${$_[0][0]} / ${$_[0][1]}) };
|
||||
$repl_env->{'+'} = sub { Integer->new(${$_[0]->nth(0)} + ${$_[0]->nth(1)}) };
|
||||
$repl_env->{'-'} = sub { Integer->new(${$_[0]->nth(0)} - ${$_[0]->nth(1)}) };
|
||||
$repl_env->{'*'} = sub { Integer->new(${$_[0]->nth(0)} * ${$_[0]->nth(1)}) };
|
||||
$repl_env->{'/'} = sub { Integer->new(${$_[0]->nth(0)} / ${$_[0]->nth(1)}) };
|
||||
|
||||
while (1) {
|
||||
my $line = readline("user> ");
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
};
|
||||
if (my $err = $@) {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
given (ref $err) {
|
||||
when (/^BlankException/) {
|
||||
# ignore and continue
|
||||
}
|
||||
default {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
}
|
||||
};
|
||||
};
|
||||
}
|
||||
|
@ -1,9 +1,10 @@
|
||||
use strict;
|
||||
use warnings FATAL => qw(all);
|
||||
use readline qw(readline);
|
||||
use readline qw(mal_readline);
|
||||
use feature qw(switch);
|
||||
use Data::Dumper;
|
||||
|
||||
use types qw(_list_Q);
|
||||
use reader;
|
||||
use printer;
|
||||
use env;
|
||||
@ -22,9 +23,20 @@ sub eval_ast {
|
||||
$env->get($$ast);
|
||||
}
|
||||
when (/^List/) {
|
||||
my @lst = map {EVAL($_, $env)} @$ast;
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return List->new(\@lst);
|
||||
}
|
||||
when (/^Vector/) {
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return Vector->new(\@lst);
|
||||
}
|
||||
when (/^HashMap/) {
|
||||
my $new_hm = {};
|
||||
foreach my $k (keys($ast->{val})) {
|
||||
$new_hm->{$k} = EVAL($ast->get($k), $env);
|
||||
}
|
||||
return HashMap->new($new_hm);
|
||||
}
|
||||
default {
|
||||
return $ast;
|
||||
}
|
||||
@ -34,12 +46,12 @@ sub eval_ast {
|
||||
sub EVAL {
|
||||
my($ast, $env) = @_;
|
||||
#print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
if (! ((ref $ast) =~ /^List/)) {
|
||||
if (! _list_Q($ast)) {
|
||||
return eval_ast($ast, $env);
|
||||
}
|
||||
|
||||
# apply list
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
my ($a0, $a1, $a2, $a3) = @{$ast->{val}};
|
||||
given ($$a0) {
|
||||
when (/^def!$/) {
|
||||
my $res = EVAL($a2, $env);
|
||||
@ -47,14 +59,14 @@ sub EVAL {
|
||||
}
|
||||
when (/^let\*$/) {
|
||||
my $let_env = Env->new($env);
|
||||
for(my $i=0; $i < scalar(@{$a1}); $i+=2) {
|
||||
$let_env->set(${$a1->[$i]}, EVAL($a1->[$i+1], $let_env));
|
||||
for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) {
|
||||
$let_env->set(${$a1->nth($i)}, EVAL($a1->nth($i+1), $let_env));
|
||||
}
|
||||
return EVAL($a2, $let_env);
|
||||
}
|
||||
default {
|
||||
my $el = eval_ast($ast, $env);
|
||||
my $f = $el->[0];
|
||||
my $f = $el->nth(0);
|
||||
return &{ $f }($el->rest());
|
||||
}
|
||||
}
|
||||
@ -73,21 +85,32 @@ sub REP {
|
||||
return PRINT(EVAL(READ($str), $repl_env));
|
||||
}
|
||||
|
||||
$repl_env->set('+', sub { Integer->new(${$_[0][0]} + ${$_[0][1]})} );
|
||||
$repl_env->set('-', sub { Integer->new(${$_[0][0]} - ${$_[0][1]})} );
|
||||
$repl_env->set('*', sub { Integer->new(${$_[0][0]} * ${$_[0][1]})} );
|
||||
$repl_env->set('/', sub { Integer->new(${$_[0][0]} / ${$_[0][1]})} );
|
||||
$repl_env->set('+', sub { Integer->new(${$_[0]->nth(0)} + ${$_[0]->nth(1)}) } );
|
||||
$repl_env->set('-', sub { Integer->new(${$_[0]->nth(0)} - ${$_[0]->nth(1)}) } );
|
||||
$repl_env->set('*', sub { Integer->new(${$_[0]->nth(0)} * ${$_[0]->nth(1)}) } );
|
||||
$repl_env->set('/', sub { Integer->new(${$_[0]->nth(0)} / ${$_[0]->nth(1)}) } );
|
||||
|
||||
while (1) {
|
||||
my $line = readline("user> ");
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
};
|
||||
if (my $err = $@) {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
given (ref $err) {
|
||||
when (/^BlankException/) {
|
||||
# ignore and continue
|
||||
}
|
||||
default {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
}
|
||||
};
|
||||
};
|
||||
}
|
||||
|
@ -1,10 +1,10 @@
|
||||
use strict;
|
||||
use warnings FATAL => qw(all);
|
||||
use readline qw(readline);
|
||||
use readline qw(mal_readline);
|
||||
use feature qw(switch);
|
||||
use Data::Dumper;
|
||||
|
||||
use types qw($nil $true $false);
|
||||
use types qw($nil $true $false _list_Q);
|
||||
use reader;
|
||||
use printer;
|
||||
use env;
|
||||
@ -24,9 +24,20 @@ sub eval_ast {
|
||||
$env->get($$ast);
|
||||
}
|
||||
when (/^List/) {
|
||||
my @lst = map {EVAL($_, $env)} @$ast;
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return List->new(\@lst);
|
||||
}
|
||||
when (/^Vector/) {
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return Vector->new(\@lst);
|
||||
}
|
||||
when (/^HashMap/) {
|
||||
my $new_hm = {};
|
||||
foreach my $k (keys($ast->{val})) {
|
||||
$new_hm->{$k} = EVAL($ast->get($k), $env);
|
||||
}
|
||||
return HashMap->new($new_hm);
|
||||
}
|
||||
default {
|
||||
return $ast;
|
||||
}
|
||||
@ -36,12 +47,12 @@ sub eval_ast {
|
||||
sub EVAL {
|
||||
my($ast, $env) = @_;
|
||||
#print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
if (! ((ref $ast) =~ /^List/)) {
|
||||
if (! _list_Q($ast)) {
|
||||
return eval_ast($ast, $env);
|
||||
}
|
||||
|
||||
# apply list
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
my ($a0, $a1, $a2, $a3) = @{$ast->{val}};
|
||||
given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) {
|
||||
when (/^def!$/) {
|
||||
my $res = EVAL($a2, $env);
|
||||
@ -49,14 +60,14 @@ sub EVAL {
|
||||
}
|
||||
when (/^let\*$/) {
|
||||
my $let_env = Env->new($env);
|
||||
for(my $i=0; $i < scalar(@{$a1}); $i+=2) {
|
||||
$let_env->set(${$a1->[$i]}, EVAL($a1->[$i+1], $let_env));
|
||||
for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) {
|
||||
$let_env->set(${$a1->nth($i)}, EVAL($a1->nth($i+1), $let_env));
|
||||
}
|
||||
return EVAL($a2, $let_env);
|
||||
}
|
||||
when (/^do$/) {
|
||||
my $el = eval_ast($ast->rest(), $env);
|
||||
return $el->[$#{$el}];
|
||||
return $el->nth($#{$el->{val}});
|
||||
}
|
||||
when (/^if$/) {
|
||||
my $cond = EVAL($a1, $env);
|
||||
@ -75,7 +86,7 @@ sub EVAL {
|
||||
}
|
||||
default {
|
||||
my $el = eval_ast($ast, $env);
|
||||
my $f = $el->[0];
|
||||
my $f = $el->nth(0);
|
||||
return &{ $f }($el->rest());
|
||||
}
|
||||
}
|
||||
@ -101,15 +112,26 @@ foreach my $n (%$core_ns) { $repl_env->set($n, $core_ns->{$n}); }
|
||||
REP("(def! not (fn* (a) (if a false true)))");
|
||||
|
||||
while (1) {
|
||||
my $line = readline("user> ");
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
};
|
||||
if (my $err = $@) {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
given (ref $err) {
|
||||
when (/^BlankException/) {
|
||||
# ignore and continue
|
||||
}
|
||||
default {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
}
|
||||
};
|
||||
};
|
||||
}
|
||||
|
@ -1,10 +1,10 @@
|
||||
use strict;
|
||||
use warnings FATAL => qw(all);
|
||||
use readline qw(readline);
|
||||
use readline qw(mal_readline);
|
||||
use feature qw(switch);
|
||||
use Data::Dumper;
|
||||
|
||||
use types qw($nil $true $false);
|
||||
use types qw($nil $true $false _list_Q);
|
||||
use reader;
|
||||
use printer;
|
||||
use env;
|
||||
@ -24,9 +24,20 @@ sub eval_ast {
|
||||
$env->get($$ast);
|
||||
}
|
||||
when (/^List/) {
|
||||
my @lst = map {EVAL($_, $env)} @$ast;
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return List->new(\@lst);
|
||||
}
|
||||
when (/^Vector/) {
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return Vector->new(\@lst);
|
||||
}
|
||||
when (/^HashMap/) {
|
||||
my $new_hm = {};
|
||||
foreach my $k (keys($ast->{val})) {
|
||||
$new_hm->{$k} = EVAL($ast->get($k), $env);
|
||||
}
|
||||
return HashMap->new($new_hm);
|
||||
}
|
||||
default {
|
||||
return $ast;
|
||||
}
|
||||
@ -39,12 +50,12 @@ sub EVAL {
|
||||
while (1) {
|
||||
|
||||
#print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
if (! ((ref $ast) =~ /^List/)) {
|
||||
if (! _list_Q($ast)) {
|
||||
return eval_ast($ast, $env);
|
||||
}
|
||||
|
||||
# apply list
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
my ($a0, $a1, $a2, $a3) = @{$ast->{val}};
|
||||
given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) {
|
||||
when (/^def!$/) {
|
||||
my $res = EVAL($a2, $env);
|
||||
@ -52,14 +63,15 @@ sub EVAL {
|
||||
}
|
||||
when (/^let\*$/) {
|
||||
my $let_env = Env->new($env);
|
||||
for(my $i=0; $i < scalar(@{$a1}); $i+=2) {
|
||||
$let_env->set(${$a1->[$i]}, EVAL($a1->[$i+1], $let_env));
|
||||
for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) {
|
||||
$let_env->set(${$a1->nth($i)}, EVAL($a1->nth($i+1), $let_env));
|
||||
}
|
||||
return EVAL($a2, $let_env);
|
||||
$ast = $a2;
|
||||
$env = $let_env;
|
||||
}
|
||||
when (/^do$/) {
|
||||
eval_ast($ast->slice(1, $#{$ast}-1), $env);
|
||||
$ast = $ast->[$#{$ast}];
|
||||
eval_ast($ast->slice(1, $#{$ast->{val}}-1), $env);
|
||||
$ast = $ast->nth($#{$ast->{val}});
|
||||
}
|
||||
when (/^if$/) {
|
||||
my $cond = EVAL($a1, $env);
|
||||
@ -74,7 +86,7 @@ sub EVAL {
|
||||
}
|
||||
default {
|
||||
my $el = eval_ast($ast, $env);
|
||||
my $f = $el->[0];
|
||||
my $f = $el->nth(0);
|
||||
if ((ref $f) =~ /^Function/) {
|
||||
$ast = $f->{ast};
|
||||
$env = $f->gen_env($el->rest());
|
||||
@ -107,15 +119,26 @@ foreach my $n (%$core_ns) { $repl_env->set($n, $core_ns->{$n}); }
|
||||
REP("(def! not (fn* (a) (if a false true)))");
|
||||
|
||||
while (1) {
|
||||
my $line = readline("user> ");
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
};
|
||||
if (my $err = $@) {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
given (ref $err) {
|
||||
when (/^BlankException/) {
|
||||
# ignore and continue
|
||||
}
|
||||
default {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
}
|
||||
};
|
||||
};
|
||||
}
|
||||
|
@ -1,10 +1,10 @@
|
||||
use strict;
|
||||
use warnings FATAL => qw(all);
|
||||
use readline qw(readline);
|
||||
use readline qw(mal_readline);
|
||||
use feature qw(switch);
|
||||
use Data::Dumper;
|
||||
|
||||
use types qw($nil $true $false);
|
||||
use types qw($nil $true $false _list_Q);
|
||||
use reader;
|
||||
use printer;
|
||||
use env;
|
||||
@ -24,9 +24,20 @@ sub eval_ast {
|
||||
$env->get($$ast);
|
||||
}
|
||||
when (/^List/) {
|
||||
my @lst = map {EVAL($_, $env)} @$ast;
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return List->new(\@lst);
|
||||
}
|
||||
when (/^Vector/) {
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return Vector->new(\@lst);
|
||||
}
|
||||
when (/^HashMap/) {
|
||||
my $new_hm = {};
|
||||
foreach my $k (keys($ast->{val})) {
|
||||
$new_hm->{$k} = EVAL($ast->get($k), $env);
|
||||
}
|
||||
return HashMap->new($new_hm);
|
||||
}
|
||||
default {
|
||||
return $ast;
|
||||
}
|
||||
@ -39,12 +50,12 @@ sub EVAL {
|
||||
while (1) {
|
||||
|
||||
#print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
if (! ((ref $ast) =~ /^List/)) {
|
||||
if (! _list_Q($ast)) {
|
||||
return eval_ast($ast, $env);
|
||||
}
|
||||
|
||||
# apply list
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
my ($a0, $a1, $a2, $a3) = @{$ast->{val}};
|
||||
given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) {
|
||||
when (/^def!$/) {
|
||||
my $res = EVAL($a2, $env);
|
||||
@ -52,14 +63,15 @@ sub EVAL {
|
||||
}
|
||||
when (/^let\*$/) {
|
||||
my $let_env = Env->new($env);
|
||||
for(my $i=0; $i < scalar(@{$a1}); $i+=2) {
|
||||
$let_env->set(${$a1->[$i]}, EVAL($a1->[$i+1], $let_env));
|
||||
for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) {
|
||||
$let_env->set(${$a1->nth($i)}, EVAL($a1->nth($i+1), $let_env));
|
||||
}
|
||||
return EVAL($a2, $let_env);
|
||||
$ast = $a2;
|
||||
$env = $let_env;
|
||||
}
|
||||
when (/^do$/) {
|
||||
eval_ast($ast->slice(1, $#{$ast}-1), $env);
|
||||
$ast = $ast->[$#{$ast}];
|
||||
eval_ast($ast->slice(1, $#{$ast->{val}}-1), $env);
|
||||
$ast = $ast->nth($#{$ast->{val}});
|
||||
}
|
||||
when (/^if$/) {
|
||||
my $cond = EVAL($a1, $env);
|
||||
@ -74,7 +86,7 @@ sub EVAL {
|
||||
}
|
||||
default {
|
||||
my $el = eval_ast($ast, $env);
|
||||
my $f = $el->[0];
|
||||
my $f = $el->nth(0);
|
||||
if ((ref $f) =~ /^Function/) {
|
||||
$ast = $f->{ast};
|
||||
$env = $f->gen_env($el->rest());
|
||||
@ -102,7 +114,7 @@ sub REP {
|
||||
|
||||
# core.pl: defined using perl
|
||||
foreach my $n (%$core_ns) { $repl_env->set($n, $core_ns->{$n}); }
|
||||
$repl_env->set('eval', sub { EVAL($_[0][0], $repl_env); });
|
||||
$repl_env->set('eval', sub { EVAL($_[0]->nth(0), $repl_env); });
|
||||
my @_argv = map {String->new($_)} @ARGV[1..$#ARGV];
|
||||
$repl_env->set('*ARGV*', List->new(\@_argv));
|
||||
|
||||
@ -110,20 +122,31 @@ $repl_env->set('*ARGV*', List->new(\@_argv));
|
||||
REP("(def! not (fn* (a) (if a false true)))");
|
||||
REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))");
|
||||
|
||||
if ($#ARGV > 0) {
|
||||
if (scalar(@ARGV) > 0) {
|
||||
REP("(load-file \"" . $ARGV[0] . "\")");
|
||||
exit 0;
|
||||
}
|
||||
while (1) {
|
||||
my $line = readline("user> ");
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
};
|
||||
if (my $err = $@) {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
given (ref $err) {
|
||||
when (/^BlankException/) {
|
||||
# ignore and continue
|
||||
}
|
||||
default {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
}
|
||||
};
|
||||
};
|
||||
}
|
||||
|
@ -1,10 +1,10 @@
|
||||
use strict;
|
||||
use warnings FATAL => qw(all);
|
||||
use readline qw(readline);
|
||||
use readline qw(mal_readline);
|
||||
use feature qw(switch);
|
||||
use Data::Dumper;
|
||||
|
||||
use types qw($nil $true $false _sequential_Q _symbol_Q);
|
||||
use types qw($nil $true $false _sequential_Q _symbol_Q _list_Q);
|
||||
use reader;
|
||||
use printer;
|
||||
use env;
|
||||
@ -19,23 +19,23 @@ sub READ {
|
||||
# eval
|
||||
sub is_pair {
|
||||
my ($x) = @_;
|
||||
return _sequential_Q($x) && scalar(@$x) > 0;
|
||||
return _sequential_Q($x) && scalar(@{$x->{val}}) > 0;
|
||||
}
|
||||
|
||||
sub quasiquote {
|
||||
my ($ast) = @_;
|
||||
if (!is_pair($ast)) {
|
||||
return List->new([Symbol->new("quote"), $ast]);
|
||||
} elsif (_symbol_Q($ast->[0]) && ${$ast->[0]} eq 'unquote') {
|
||||
return $ast->[1];
|
||||
} elsif (is_pair($ast->[0]) && _symbol_Q($ast->[0][0]) &&
|
||||
${$ast->[0][0]} eq 'splice-unquote') {
|
||||
} elsif (_symbol_Q($ast->nth(0)) && ${$ast->nth(0)} eq 'unquote') {
|
||||
return $ast->nth(1);
|
||||
} elsif (is_pair($ast->nth(0)) && _symbol_Q($ast->nth(0)->nth(0)) &&
|
||||
${$ast->nth(0)->nth(0)} eq 'splice-unquote') {
|
||||
return List->new([Symbol->new("concat"),
|
||||
$ast->[0][1],
|
||||
$ast->nth(0)->nth(1),
|
||||
quasiquote($ast->rest())]);
|
||||
} else {
|
||||
return List->new([Symbol->new("cons"),
|
||||
quasiquote($ast->[0]),
|
||||
quasiquote($ast->nth(0)),
|
||||
quasiquote($ast->rest())]);
|
||||
}
|
||||
}
|
||||
@ -47,9 +47,20 @@ sub eval_ast {
|
||||
$env->get($$ast);
|
||||
}
|
||||
when (/^List/) {
|
||||
my @lst = map {EVAL($_, $env)} @$ast;
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return List->new(\@lst);
|
||||
}
|
||||
when (/^Vector/) {
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return Vector->new(\@lst);
|
||||
}
|
||||
when (/^HashMap/) {
|
||||
my $new_hm = {};
|
||||
foreach my $k (keys($ast->{val})) {
|
||||
$new_hm->{$k} = EVAL($ast->get($k), $env);
|
||||
}
|
||||
return HashMap->new($new_hm);
|
||||
}
|
||||
default {
|
||||
return $ast;
|
||||
}
|
||||
@ -62,12 +73,12 @@ sub EVAL {
|
||||
while (1) {
|
||||
|
||||
#print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
if (! ((ref $ast) =~ /^List/)) {
|
||||
if (! _list_Q($ast)) {
|
||||
return eval_ast($ast, $env);
|
||||
}
|
||||
|
||||
# apply list
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
my ($a0, $a1, $a2, $a3) = @{$ast->{val}};
|
||||
given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) {
|
||||
when (/^def!$/) {
|
||||
my $res = EVAL($a2, $env);
|
||||
@ -75,10 +86,11 @@ sub EVAL {
|
||||
}
|
||||
when (/^let\*$/) {
|
||||
my $let_env = Env->new($env);
|
||||
for(my $i=0; $i < scalar(@{$a1}); $i+=2) {
|
||||
$let_env->set(${$a1->[$i]}, EVAL($a1->[$i+1], $let_env));
|
||||
for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) {
|
||||
$let_env->set(${$a1->nth($i)}, EVAL($a1->nth($i+1), $let_env));
|
||||
}
|
||||
return EVAL($a2, $let_env);
|
||||
$ast = $a2;
|
||||
$env = $let_env;
|
||||
}
|
||||
when (/^quote$/) {
|
||||
return $a1;
|
||||
@ -87,8 +99,8 @@ sub EVAL {
|
||||
return EVAL(quasiquote($a1), $env);
|
||||
}
|
||||
when (/^do$/) {
|
||||
eval_ast($ast->slice(1, $#{$ast}-1), $env);
|
||||
$ast = $ast->[$#{$ast}];
|
||||
eval_ast($ast->slice(1, $#{$ast->{val}}-1), $env);
|
||||
$ast = $ast->nth($#{$ast->{val}});
|
||||
}
|
||||
when (/^if$/) {
|
||||
my $cond = EVAL($a1, $env);
|
||||
@ -103,7 +115,7 @@ sub EVAL {
|
||||
}
|
||||
default {
|
||||
my $el = eval_ast($ast, $env);
|
||||
my $f = $el->[0];
|
||||
my $f = $el->nth(0);
|
||||
if ((ref $f) =~ /^Function/) {
|
||||
$ast = $f->{ast};
|
||||
$env = $f->gen_env($el->rest());
|
||||
@ -131,7 +143,7 @@ sub REP {
|
||||
|
||||
# core.pl: defined using perl
|
||||
foreach my $n (%$core_ns) { $repl_env->set($n, $core_ns->{$n}); }
|
||||
$repl_env->set('eval', sub { EVAL($_[0][0], $repl_env); });
|
||||
$repl_env->set('eval', sub { EVAL($_[0]->nth(0), $repl_env); });
|
||||
my @_argv = map {String->new($_)} @ARGV[1..$#ARGV];
|
||||
$repl_env->set('*ARGV*', List->new(\@_argv));
|
||||
|
||||
@ -139,20 +151,31 @@ $repl_env->set('*ARGV*', List->new(\@_argv));
|
||||
REP("(def! not (fn* (a) (if a false true)))");
|
||||
REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))");
|
||||
|
||||
if ($#ARGV > 0) {
|
||||
if (scalar(@ARGV) > 0) {
|
||||
REP("(load-file \"" . $ARGV[0] . "\")");
|
||||
exit 0;
|
||||
}
|
||||
while (1) {
|
||||
my $line = readline("user> ");
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
};
|
||||
if (my $err = $@) {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
given (ref $err) {
|
||||
when (/^BlankException/) {
|
||||
# ignore and continue
|
||||
}
|
||||
default {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
}
|
||||
};
|
||||
};
|
||||
}
|
||||
|
@ -1,6 +1,6 @@
|
||||
use strict;
|
||||
use warnings FATAL => qw(all);
|
||||
use readline qw(readline);
|
||||
use readline qw(mal_readline);
|
||||
use feature qw(switch);
|
||||
use Data::Dumper;
|
||||
|
||||
@ -19,23 +19,23 @@ sub READ {
|
||||
# eval
|
||||
sub is_pair {
|
||||
my ($x) = @_;
|
||||
return _sequential_Q($x) && scalar(@$x) > 0;
|
||||
return _sequential_Q($x) && scalar(@{$x->{val}}) > 0;
|
||||
}
|
||||
|
||||
sub quasiquote {
|
||||
my ($ast) = @_;
|
||||
if (!is_pair($ast)) {
|
||||
return List->new([Symbol->new("quote"), $ast]);
|
||||
} elsif (_symbol_Q($ast->[0]) && ${$ast->[0]} eq 'unquote') {
|
||||
return $ast->[1];
|
||||
} elsif (is_pair($ast->[0]) && _symbol_Q($ast->[0][0]) &&
|
||||
${$ast->[0][0]} eq 'splice-unquote') {
|
||||
} elsif (_symbol_Q($ast->nth(0)) && ${$ast->nth(0)} eq 'unquote') {
|
||||
return $ast->nth(1);
|
||||
} elsif (is_pair($ast->nth(0)) && _symbol_Q($ast->nth(0)->nth(0)) &&
|
||||
${$ast->nth(0)->nth(0)} eq 'splice-unquote') {
|
||||
return List->new([Symbol->new("concat"),
|
||||
$ast->[0][1],
|
||||
$ast->nth(0)->nth(1),
|
||||
quasiquote($ast->rest())]);
|
||||
} else {
|
||||
return List->new([Symbol->new("cons"),
|
||||
quasiquote($ast->[0]),
|
||||
quasiquote($ast->nth(0)),
|
||||
quasiquote($ast->rest())]);
|
||||
}
|
||||
}
|
||||
@ -43,9 +43,9 @@ sub quasiquote {
|
||||
sub is_macro_call {
|
||||
my ($ast, $env) = @_;
|
||||
if (_list_Q($ast) &&
|
||||
_symbol_Q($ast->[0]) &&
|
||||
$env->find(${$ast->[0]})) {
|
||||
my ($f) = $env->get(${$ast->[0]});
|
||||
_symbol_Q($ast->nth(0)) &&
|
||||
$env->find(${$ast->nth(0)})) {
|
||||
my ($f) = $env->get(${$ast->nth(0)});
|
||||
if ((ref $f) =~ /^Function/) {
|
||||
return $f->{ismacro};
|
||||
}
|
||||
@ -56,7 +56,7 @@ sub is_macro_call {
|
||||
sub macroexpand {
|
||||
my ($ast, $env) = @_;
|
||||
while (is_macro_call($ast, $env)) {
|
||||
my $mac = $env->get(${$ast->[0]});
|
||||
my $mac = $env->get(${$ast->nth(0)});
|
||||
$ast = $mac->apply($ast->rest());
|
||||
}
|
||||
return $ast;
|
||||
@ -70,9 +70,20 @@ sub eval_ast {
|
||||
$env->get($$ast);
|
||||
}
|
||||
when (/^List/) {
|
||||
my @lst = map {EVAL($_, $env)} @$ast;
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return List->new(\@lst);
|
||||
}
|
||||
when (/^Vector/) {
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return Vector->new(\@lst);
|
||||
}
|
||||
when (/^HashMap/) {
|
||||
my $new_hm = {};
|
||||
foreach my $k (keys($ast->{val})) {
|
||||
$new_hm->{$k} = EVAL($ast->get($k), $env);
|
||||
}
|
||||
return HashMap->new($new_hm);
|
||||
}
|
||||
default {
|
||||
return $ast;
|
||||
}
|
||||
@ -93,7 +104,7 @@ sub EVAL {
|
||||
$ast = macroexpand($ast, $env);
|
||||
if (! _list_Q($ast)) { return $ast; }
|
||||
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
my ($a0, $a1, $a2, $a3) = @{$ast->{val}};
|
||||
given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) {
|
||||
when (/^def!$/) {
|
||||
my $res = EVAL($a2, $env);
|
||||
@ -101,10 +112,11 @@ sub EVAL {
|
||||
}
|
||||
when (/^let\*$/) {
|
||||
my $let_env = Env->new($env);
|
||||
for(my $i=0; $i < scalar(@{$a1}); $i+=2) {
|
||||
$let_env->set(${$a1->[$i]}, EVAL($a1->[$i+1], $let_env));
|
||||
for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) {
|
||||
$let_env->set(${$a1->nth($i)}, EVAL($a1->nth($i+1), $let_env));
|
||||
}
|
||||
return EVAL($a2, $let_env);
|
||||
$ast = $a2;
|
||||
$env = $let_env;
|
||||
}
|
||||
when (/^quote$/) {
|
||||
return $a1;
|
||||
@ -121,8 +133,8 @@ sub EVAL {
|
||||
return macroexpand($a1, $env);
|
||||
}
|
||||
when (/^do$/) {
|
||||
eval_ast($ast->slice(1, $#{$ast}-1), $env);
|
||||
$ast = $ast->[$#{$ast}];
|
||||
eval_ast($ast->slice(1, $#{$ast->{val}}-1), $env);
|
||||
$ast = $ast->nth($#{$ast->{val}});
|
||||
}
|
||||
when (/^if$/) {
|
||||
my $cond = EVAL($a1, $env);
|
||||
@ -137,7 +149,7 @@ sub EVAL {
|
||||
}
|
||||
default {
|
||||
my $el = eval_ast($ast, $env);
|
||||
my $f = $el->[0];
|
||||
my $f = $el->nth(0);
|
||||
if ((ref $f) =~ /^Function/) {
|
||||
$ast = $f->{ast};
|
||||
$env = $f->gen_env($el->rest());
|
||||
@ -165,7 +177,7 @@ sub REP {
|
||||
|
||||
# core.pl: defined using perl
|
||||
foreach my $n (%$core_ns) { $repl_env->set($n, $core_ns->{$n}); }
|
||||
$repl_env->set('eval', sub { EVAL($_[0][0], $repl_env); });
|
||||
$repl_env->set('eval', sub { EVAL($_[0]->nth(0), $repl_env); });
|
||||
my @_argv = map {String->new($_)} @ARGV[1..$#ARGV];
|
||||
$repl_env->set('*ARGV*', List->new(\@_argv));
|
||||
|
||||
@ -173,20 +185,31 @@ $repl_env->set('*ARGV*', List->new(\@_argv));
|
||||
REP("(def! not (fn* (a) (if a false true)))");
|
||||
REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))");
|
||||
|
||||
if ($#ARGV > 0) {
|
||||
if (scalar(@ARGV) > 0) {
|
||||
REP("(load-file \"" . $ARGV[0] . "\")");
|
||||
exit 0;
|
||||
}
|
||||
while (1) {
|
||||
my $line = readline("user> ");
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
};
|
||||
if (my $err = $@) {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
given (ref $err) {
|
||||
when (/^BlankException/) {
|
||||
# ignore and continue
|
||||
}
|
||||
default {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
}
|
||||
};
|
||||
};
|
||||
}
|
||||
|
@ -1,6 +1,6 @@
|
||||
use strict;
|
||||
use warnings FATAL => qw(all);
|
||||
use readline qw(readline);
|
||||
use readline qw(mal_readline);
|
||||
use feature qw(switch);
|
||||
use Data::Dumper;
|
||||
|
||||
@ -20,23 +20,23 @@ sub READ {
|
||||
# eval
|
||||
sub is_pair {
|
||||
my ($x) = @_;
|
||||
return _sequential_Q($x) && scalar(@$x) > 0;
|
||||
return _sequential_Q($x) && scalar(@{$x->{val}}) > 0;
|
||||
}
|
||||
|
||||
sub quasiquote {
|
||||
my ($ast) = @_;
|
||||
if (!is_pair($ast)) {
|
||||
return List->new([Symbol->new("quote"), $ast]);
|
||||
} elsif (_symbol_Q($ast->[0]) && ${$ast->[0]} eq 'unquote') {
|
||||
return $ast->[1];
|
||||
} elsif (is_pair($ast->[0]) && _symbol_Q($ast->[0][0]) &&
|
||||
${$ast->[0][0]} eq 'splice-unquote') {
|
||||
} elsif (_symbol_Q($ast->nth(0)) && ${$ast->nth(0)} eq 'unquote') {
|
||||
return $ast->nth(1);
|
||||
} elsif (is_pair($ast->nth(0)) && _symbol_Q($ast->nth(0)->nth(0)) &&
|
||||
${$ast->nth(0)->nth(0)} eq 'splice-unquote') {
|
||||
return List->new([Symbol->new("concat"),
|
||||
$ast->[0][1],
|
||||
$ast->nth(0)->nth(1),
|
||||
quasiquote($ast->rest())]);
|
||||
} else {
|
||||
return List->new([Symbol->new("cons"),
|
||||
quasiquote($ast->[0]),
|
||||
quasiquote($ast->nth(0)),
|
||||
quasiquote($ast->rest())]);
|
||||
}
|
||||
}
|
||||
@ -44,9 +44,9 @@ sub quasiquote {
|
||||
sub is_macro_call {
|
||||
my ($ast, $env) = @_;
|
||||
if (_list_Q($ast) &&
|
||||
_symbol_Q($ast->[0]) &&
|
||||
$env->find(${$ast->[0]})) {
|
||||
my ($f) = $env->get(${$ast->[0]});
|
||||
_symbol_Q($ast->nth(0)) &&
|
||||
$env->find(${$ast->nth(0)})) {
|
||||
my ($f) = $env->get(${$ast->nth(0)});
|
||||
if ((ref $f) =~ /^Function/) {
|
||||
return $f->{ismacro};
|
||||
}
|
||||
@ -57,7 +57,7 @@ sub is_macro_call {
|
||||
sub macroexpand {
|
||||
my ($ast, $env) = @_;
|
||||
while (is_macro_call($ast, $env)) {
|
||||
my $mac = $env->get(${$ast->[0]});
|
||||
my $mac = $env->get(${$ast->nth(0)});
|
||||
$ast = $mac->apply($ast->rest());
|
||||
}
|
||||
return $ast;
|
||||
@ -71,9 +71,20 @@ sub eval_ast {
|
||||
$env->get($$ast);
|
||||
}
|
||||
when (/^List/) {
|
||||
my @lst = map {EVAL($_, $env)} @$ast;
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return List->new(\@lst);
|
||||
}
|
||||
when (/^Vector/) {
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return Vector->new(\@lst);
|
||||
}
|
||||
when (/^HashMap/) {
|
||||
my $new_hm = {};
|
||||
foreach my $k (keys($ast->{val})) {
|
||||
$new_hm->{$k} = EVAL($ast->get($k), $env);
|
||||
}
|
||||
return HashMap->new($new_hm);
|
||||
}
|
||||
default {
|
||||
return $ast;
|
||||
}
|
||||
@ -94,7 +105,7 @@ sub EVAL {
|
||||
$ast = macroexpand($ast, $env);
|
||||
if (! _list_Q($ast)) { return $ast; }
|
||||
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
my ($a0, $a1, $a2, $a3) = @{$ast->{val}};
|
||||
given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) {
|
||||
when (/^def!$/) {
|
||||
my $res = EVAL($a2, $env);
|
||||
@ -102,10 +113,11 @@ sub EVAL {
|
||||
}
|
||||
when (/^let\*$/) {
|
||||
my $let_env = Env->new($env);
|
||||
for(my $i=0; $i < scalar(@{$a1}); $i+=2) {
|
||||
$let_env->set(${$a1->[$i]}, EVAL($a1->[$i+1], $let_env));
|
||||
for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) {
|
||||
$let_env->set(${$a1->nth($i)}, EVAL($a1->nth($i+1), $let_env));
|
||||
}
|
||||
return EVAL($a2, $let_env);
|
||||
$ast = $a2;
|
||||
$env = $let_env;
|
||||
}
|
||||
when (/^quote$/) {
|
||||
return $a1;
|
||||
@ -125,8 +137,8 @@ sub EVAL {
|
||||
return pl_to_mal(eval(${$a1}));
|
||||
}
|
||||
when (/^do$/) {
|
||||
eval_ast($ast->slice(1, $#{$ast}-1), $env);
|
||||
$ast = $ast->[$#{$ast}];
|
||||
eval_ast($ast->slice(1, $#{$ast->{val}}-1), $env);
|
||||
$ast = $ast->nth($#{$ast->{val}});
|
||||
}
|
||||
when (/^if$/) {
|
||||
my $cond = EVAL($a1, $env);
|
||||
@ -141,7 +153,7 @@ sub EVAL {
|
||||
}
|
||||
default {
|
||||
my $el = eval_ast($ast, $env);
|
||||
my $f = $el->[0];
|
||||
my $f = $el->nth(0);
|
||||
if ((ref $f) =~ /^Function/) {
|
||||
$ast = $f->{ast};
|
||||
$env = $f->gen_env($el->rest());
|
||||
@ -169,7 +181,7 @@ sub REP {
|
||||
|
||||
# core.pl: defined using perl
|
||||
foreach my $n (%$core_ns) { $repl_env->set($n, $core_ns->{$n}); }
|
||||
$repl_env->set('eval', sub { EVAL($_[0][0], $repl_env); });
|
||||
$repl_env->set('eval', sub { EVAL($_[0]->nth(0), $repl_env); });
|
||||
my @_argv = map {String->new($_)} @ARGV[1..$#ARGV];
|
||||
$repl_env->set('*ARGV*', List->new(\@_argv));
|
||||
|
||||
@ -177,20 +189,31 @@ $repl_env->set('*ARGV*', List->new(\@_argv));
|
||||
REP("(def! not (fn* (a) (if a false true)))");
|
||||
REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))");
|
||||
|
||||
if ($#ARGV > 0) {
|
||||
if (scalar(@ARGV) > 0) {
|
||||
REP("(load-file \"" . $ARGV[0] . "\")");
|
||||
exit 0;
|
||||
}
|
||||
while (1) {
|
||||
my $line = readline("user> ");
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
};
|
||||
if (my $err = $@) {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
given (ref $err) {
|
||||
when (/^BlankException/) {
|
||||
# ignore and continue
|
||||
}
|
||||
default {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
}
|
||||
};
|
||||
};
|
||||
}
|
||||
|
@ -1,6 +1,6 @@
|
||||
use strict;
|
||||
use warnings FATAL => qw(all);
|
||||
use readline qw(readline);
|
||||
use readline qw(mal_readline);
|
||||
use feature qw(switch);
|
||||
use Data::Dumper;
|
||||
|
||||
@ -20,23 +20,23 @@ sub READ {
|
||||
# eval
|
||||
sub is_pair {
|
||||
my ($x) = @_;
|
||||
return _sequential_Q($x) && scalar(@$x) > 0;
|
||||
return _sequential_Q($x) && scalar(@{$x->{val}}) > 0;
|
||||
}
|
||||
|
||||
sub quasiquote {
|
||||
my ($ast) = @_;
|
||||
if (!is_pair($ast)) {
|
||||
return List->new([Symbol->new("quote"), $ast]);
|
||||
} elsif (_symbol_Q($ast->[0]) && ${$ast->[0]} eq 'unquote') {
|
||||
return $ast->[1];
|
||||
} elsif (is_pair($ast->[0]) && _symbol_Q($ast->[0][0]) &&
|
||||
${$ast->[0][0]} eq 'splice-unquote') {
|
||||
} elsif (_symbol_Q($ast->nth(0)) && ${$ast->nth(0)} eq 'unquote') {
|
||||
return $ast->nth(1);
|
||||
} elsif (is_pair($ast->nth(0)) && _symbol_Q($ast->nth(0)->nth(0)) &&
|
||||
${$ast->nth(0)->nth(0)} eq 'splice-unquote') {
|
||||
return List->new([Symbol->new("concat"),
|
||||
$ast->[0][1],
|
||||
$ast->nth(0)->nth(1),
|
||||
quasiquote($ast->rest())]);
|
||||
} else {
|
||||
return List->new([Symbol->new("cons"),
|
||||
quasiquote($ast->[0]),
|
||||
quasiquote($ast->nth(0)),
|
||||
quasiquote($ast->rest())]);
|
||||
}
|
||||
}
|
||||
@ -44,9 +44,9 @@ sub quasiquote {
|
||||
sub is_macro_call {
|
||||
my ($ast, $env) = @_;
|
||||
if (_list_Q($ast) &&
|
||||
_symbol_Q($ast->[0]) &&
|
||||
$env->find(${$ast->[0]})) {
|
||||
my ($f) = $env->get(${$ast->[0]});
|
||||
_symbol_Q($ast->nth(0)) &&
|
||||
$env->find(${$ast->nth(0)})) {
|
||||
my ($f) = $env->get(${$ast->nth(0)});
|
||||
if ((ref $f) =~ /^Function/) {
|
||||
return $f->{ismacro};
|
||||
}
|
||||
@ -57,7 +57,7 @@ sub is_macro_call {
|
||||
sub macroexpand {
|
||||
my ($ast, $env) = @_;
|
||||
while (is_macro_call($ast, $env)) {
|
||||
my $mac = $env->get(${$ast->[0]});
|
||||
my $mac = $env->get(${$ast->nth(0)});
|
||||
$ast = $mac->apply($ast->rest());
|
||||
}
|
||||
return $ast;
|
||||
@ -71,9 +71,20 @@ sub eval_ast {
|
||||
$env->get($$ast);
|
||||
}
|
||||
when (/^List/) {
|
||||
my @lst = map {EVAL($_, $env)} @$ast;
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return List->new(\@lst);
|
||||
}
|
||||
when (/^Vector/) {
|
||||
my @lst = map {EVAL($_, $env)} @{$ast->{val}};
|
||||
return Vector->new(\@lst);
|
||||
}
|
||||
when (/^HashMap/) {
|
||||
my $new_hm = {};
|
||||
foreach my $k (keys($ast->{val})) {
|
||||
$new_hm->{$k} = EVAL($ast->get($k), $env);
|
||||
}
|
||||
return HashMap->new($new_hm);
|
||||
}
|
||||
default {
|
||||
return $ast;
|
||||
}
|
||||
@ -94,7 +105,7 @@ sub EVAL {
|
||||
$ast = macroexpand($ast, $env);
|
||||
if (! _list_Q($ast)) { return $ast; }
|
||||
|
||||
my ($a0, $a1, $a2, $a3) = @$ast;
|
||||
my ($a0, $a1, $a2, $a3) = @{$ast->{val}};
|
||||
given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) {
|
||||
when (/^def!$/) {
|
||||
my $res = EVAL($a2, $env);
|
||||
@ -102,10 +113,11 @@ sub EVAL {
|
||||
}
|
||||
when (/^let\*$/) {
|
||||
my $let_env = Env->new($env);
|
||||
for(my $i=0; $i < scalar(@{$a1}); $i+=2) {
|
||||
$let_env->set(${$a1->[$i]}, EVAL($a1->[$i+1], $let_env));
|
||||
for(my $i=0; $i < scalar(@{$a1->{val}}); $i+=2) {
|
||||
$let_env->set(${$a1->nth($i)}, EVAL($a1->nth($i+1), $let_env));
|
||||
}
|
||||
return EVAL($a2, $let_env);
|
||||
$ast = $a2;
|
||||
$env = $let_env;
|
||||
}
|
||||
when (/^quote$/) {
|
||||
return $a1;
|
||||
@ -125,29 +137,35 @@ sub EVAL {
|
||||
return pl_to_mal(eval(${$a1}));
|
||||
}
|
||||
when (/^try\*$/) {
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
return EVAL($a1, $env);
|
||||
};
|
||||
if (my $err = $@) {
|
||||
if ($a2 && ${$a2->[0]} eq "catch\*") {
|
||||
my $exc;
|
||||
if (ref $err) {
|
||||
$exc = $err;
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
$ret = EVAL($a1, $env);
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
if ($a2 && ${$a2->nth(0)} eq "catch\*") {
|
||||
my $exc;
|
||||
if (ref $err) {
|
||||
$exc = $err;
|
||||
} else {
|
||||
$exc = String->new(substr $err, 0, -1);
|
||||
}
|
||||
return EVAL($a2->nth(2), Env->new($env,
|
||||
List->new([$a2->nth(1)]),
|
||||
List->new([$exc])));
|
||||
} else {
|
||||
$exc = String->new(substr $err, 0, -1);
|
||||
die $err;
|
||||
}
|
||||
return EVAL($a2->[2], Env->new($env,
|
||||
List->new([$a2->[1]]),
|
||||
List->new([$exc])));
|
||||
} else {
|
||||
die $err;
|
||||
}
|
||||
}
|
||||
};
|
||||
return $ret;
|
||||
};
|
||||
}
|
||||
when (/^do$/) {
|
||||
eval_ast($ast->slice(1, $#{$ast}-1), $env);
|
||||
$ast = $ast->[$#{$ast}];
|
||||
eval_ast($ast->slice(1, $#{$ast->{val}}-1), $env);
|
||||
$ast = $ast->nth($#{$ast->{val}});
|
||||
}
|
||||
when (/^if$/) {
|
||||
my $cond = EVAL($a1, $env);
|
||||
@ -162,7 +180,7 @@ sub EVAL {
|
||||
}
|
||||
default {
|
||||
my $el = eval_ast($ast, $env);
|
||||
my $f = $el->[0];
|
||||
my $f = $el->nth(0);
|
||||
if ((ref $f) =~ /^Function/) {
|
||||
$ast = $f->{ast};
|
||||
$env = $f->gen_env($el->rest());
|
||||
@ -190,28 +208,44 @@ sub REP {
|
||||
|
||||
# core.pl: defined using perl
|
||||
foreach my $n (%$core_ns) { $repl_env->set($n, $core_ns->{$n}); }
|
||||
$repl_env->set('eval', sub { EVAL($_[0][0], $repl_env); });
|
||||
$repl_env->set('eval', sub { EVAL($_[0]->nth(0), $repl_env); });
|
||||
my @_argv = map {String->new($_)} @ARGV[1..$#ARGV];
|
||||
$repl_env->set('*ARGV*', List->new(\@_argv));
|
||||
|
||||
# core.mal: defined using the language itself
|
||||
REP("(def! *host-language* \"javascript\")");
|
||||
REP("(def! not (fn* (a) (if a false true)))");
|
||||
REP("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))");
|
||||
REP("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))");
|
||||
REP("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))");
|
||||
|
||||
if ($#ARGV > 0) {
|
||||
|
||||
if (scalar(@ARGV) > 0) {
|
||||
REP("(load-file \"" . $ARGV[0] . "\")");
|
||||
exit 0;
|
||||
}
|
||||
REP("(println (str \"Mal [\" *host-language* \"]\"))");
|
||||
while (1) {
|
||||
my $line = readline("user> ");
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
};
|
||||
if (my $err = $@) {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
use autodie; # always "throw" errors
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
given (ref $err) {
|
||||
when (/^BlankException/) {
|
||||
# ignore and continue
|
||||
}
|
||||
default {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
}
|
||||
};
|
||||
};
|
||||
}
|
||||
|
@ -3,10 +3,11 @@ use strict;
|
||||
use warnings FATAL => qw(all);
|
||||
use feature qw(switch);
|
||||
use Exporter 'import';
|
||||
our @EXPORT_OK = qw(_sequential_Q _equal_Q
|
||||
our @EXPORT_OK = qw(_sequential_Q _equal_Q _clone
|
||||
$nil $true $false
|
||||
_symbol_Q _nil_Q _true_Q _false_Q _list_Q
|
||||
_hash_map _hash_map_Q _assoc_BANG _dissoc_BANG);
|
||||
_symbol_Q _nil_Q _true_Q _false_Q _list_Q _vector_Q
|
||||
_hash_map _hash_map_Q _assoc_BANG _dissoc_BANG
|
||||
_atom_Q);
|
||||
|
||||
use Data::Dumper;
|
||||
|
||||
@ -27,16 +28,19 @@ sub _equal_Q {
|
||||
return $$a eq $$b;
|
||||
}
|
||||
when (/^List/ || /^Vector/) {
|
||||
if (! scalar(@$a) == scalar(@$b)) {
|
||||
if (! scalar(@{$a->{val}}) == scalar(@{$b->{val}})) {
|
||||
return 0;
|
||||
}
|
||||
for (my $i=0; $i<scalar(@$a); $i++) {
|
||||
if (! _equal_Q($a->[$i], $b->[$i])) {
|
||||
for (my $i=0; $i<scalar(@{$a->{val}}); $i++) {
|
||||
if (! _equal_Q($a->nth($i), $b->nth($i))) {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
when (/^HashMap/) {
|
||||
die "TODO: Hash map comparison\n";
|
||||
}
|
||||
default {
|
||||
return $$a eq $$b;
|
||||
}
|
||||
@ -44,6 +48,34 @@ sub _equal_Q {
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _clone {
|
||||
my ($obj) = @_;
|
||||
given (ref $obj) {
|
||||
when (/^List/) {
|
||||
return List->new( [ @{$obj->{val}} ] );
|
||||
}
|
||||
when (/^Vector/) {
|
||||
return Vector->new( [ @{$obj->{val}} ] );
|
||||
}
|
||||
when (/^HashMap/) {
|
||||
return Vector->new( { %{$obj->{val}} } );
|
||||
}
|
||||
when (/^Function/) {
|
||||
return Function->new_from_hash( { %{$obj} } );
|
||||
}
|
||||
default {
|
||||
die "Clone of non-collection\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Errors/Exceptions
|
||||
|
||||
{
|
||||
package BlankException;
|
||||
sub new { my $class = shift; bless String->new("Blank Line") => $class }
|
||||
}
|
||||
|
||||
# Scalars
|
||||
|
||||
{
|
||||
@ -92,9 +124,11 @@ sub _symbol_Q { (ref $_[0]) =~ /^Symbol/ }
|
||||
|
||||
{
|
||||
package List;
|
||||
sub new { my $class = shift; bless $_[0], $class }
|
||||
sub rest { my @arr = @{$_[0]}; List->new([@arr[1..$#arr]]); }
|
||||
sub slice { my @arr = @{$_[0]}; List->new([@arr[$_[1]..$_[2]]]); }
|
||||
sub new { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
|
||||
sub nth { $_[0]->{val}->[$_[1]]; }
|
||||
#sub _val { $_[0]->{val}->[$_[1]]->{val}; } # return value of nth item
|
||||
sub rest { my @arr = @{$_[0]->{val}}; List->new([@arr[1..$#arr]]); }
|
||||
sub slice { my @arr = @{$_[0]->{val}}; List->new([@arr[$_[1]..$_[2]]]); }
|
||||
}
|
||||
|
||||
sub _list_Q { (ref $_[0]) =~ /^List/ }
|
||||
@ -104,9 +138,11 @@ sub _list_Q { (ref $_[0]) =~ /^List/ }
|
||||
|
||||
{
|
||||
package Vector;
|
||||
sub new { my $class = shift; bless $_[0], $class }
|
||||
sub rest { my @arr = @{$_[0]}; List->new([@arr[1..$#arr]]); }
|
||||
sub slice { my @arr = @{$_[0]}; List->new([@arr[$_[1]..$_[2]]]); }
|
||||
sub new { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
|
||||
sub nth { $_[0]->{val}->[$_[1]]; }
|
||||
#sub _val { $_[0]->{val}->[$_[1]]->{val}; } # return value of nth item
|
||||
sub rest { my @arr = @{$_[0]->{val}}; List->new([@arr[1..$#arr]]); }
|
||||
sub slice { my @arr = @{$_[0]->{val}}; List->new([@arr[$_[1]..$_[2]]]); }
|
||||
}
|
||||
|
||||
sub _vector_Q { (ref $_[0]) =~ /^Vector/ }
|
||||
@ -116,7 +152,8 @@ sub _vector_Q { (ref $_[0]) =~ /^Vector/ }
|
||||
|
||||
{
|
||||
package HashMap;
|
||||
sub new { my $class = shift; bless $_[0], $class }
|
||||
sub new { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
|
||||
sub get { $_[0]->{val}->{$_[1]}; }
|
||||
}
|
||||
|
||||
sub _hash_map {
|
||||
@ -154,12 +191,14 @@ sub _hash_map_Q { (ref $_[0]) =~ /^HashMap/ }
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my ($eval, $ast, $env, $params) = @_;
|
||||
bless {'eval'=>$eval,
|
||||
bless {'meta'=>$nil,
|
||||
'eval'=>$eval,
|
||||
'ast'=>$ast,
|
||||
'env'=>$env,
|
||||
'params'=>$params,
|
||||
'ismacro'=>0}, $class
|
||||
}
|
||||
sub new_from_hash { my $class = shift; bless $_[0], $class }
|
||||
sub gen_env {
|
||||
my $self = $_[0];
|
||||
return Env->new($self->{env}, $self->{params}, $_[1]);
|
||||
@ -170,4 +209,14 @@ sub _hash_map_Q { (ref $_[0]) =~ /^HashMap/ }
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Atoms
|
||||
|
||||
{
|
||||
package Atom;
|
||||
sub new { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
|
||||
}
|
||||
|
||||
sub _atom_Q { (ref $_[0]) =~ /^Atom/ }
|
||||
|
||||
1;
|
||||
|
@ -100,5 +100,5 @@ def read_form(reader):
|
||||
|
||||
def read_str(str):
|
||||
tokens = tokenize(str)
|
||||
if len(tokens) == 0: raise Blank
|
||||
if len(tokens) == 0: raise Blank("Blank Line")
|
||||
return read_form(Reader(tokens))
|
||||
|
@ -1,3 +1,16 @@
|
||||
;; Testing read-string, eval and slurp
|
||||
|
||||
(read-string "(+ 2 3)")
|
||||
;=>(+ 2 3)
|
||||
|
||||
(eval (read-string "(+ 2 3)"))
|
||||
;=>5
|
||||
|
||||
;;; TODO: fix newline matching so that this works
|
||||
;;;(slurp "../tests/test.txt")
|
||||
;;;;=>"A line of text\n"
|
||||
|
||||
|
||||
;; Testing load-file
|
||||
|
||||
(load-file "../tests/inc.mal")
|
||||
|
@ -66,6 +66,12 @@
|
||||
(read-string "(1 2 (3 4) nil)")
|
||||
;=>(1 2 (3 4) nil)
|
||||
|
||||
(read-string "7 ;; comment")
|
||||
;=>7
|
||||
|
||||
(read-string ";; comment")
|
||||
;=>nil
|
||||
|
||||
(eval (read-string "(+ 4 5)"))
|
||||
;=>9
|
||||
|
||||
@ -91,6 +97,15 @@
|
||||
(sequential? "abc")
|
||||
;=>false
|
||||
|
||||
;; Testing vector functions
|
||||
|
||||
(vector? [10 11])
|
||||
;=>true
|
||||
(vector? '(12 13))
|
||||
;=>false
|
||||
(vector 3 4 5)
|
||||
;=>[3 4 5]
|
||||
|
||||
;; Testing conj function
|
||||
(conj (list) 1)
|
||||
;=>(1)
|
||||
@ -198,9 +213,6 @@
|
||||
(meta (fn* (a) a))
|
||||
;=>nil
|
||||
|
||||
(meta +)
|
||||
;=>nil
|
||||
|
||||
(with-meta [1 2 3] {"a" 1})
|
||||
;=>[1 2 3]
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user