kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-10-26 14:22:25 +03:00
Code Issues Projects Releases Wiki Activity

Perl: add vector, hash-map, metadata, atom support. TCO let*

Browse Source 
- 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:
Joel Martin 2014-04-23 21:46:57 -05:00
parent 85cc53f35b
commit 89bd4de1e2
21 changed files with 722 additions and 359 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
docs/TODO
View File

@ -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:

22
docs/step_notes.txt
View File

@ -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
View File

@ -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
View File

@ -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);
}
}
}

13
perl/printer.pm
View File

@ -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; }
}

9
perl/reader.pm
View File

@ -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));
}

4
perl/readline.pm
View File

@ -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) {

33
perl/step1_read_print.pl
View File

@ -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";
}
}
};
};
}

59
perl/step2_eval.pl
View File

@ -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";
}
}
};
};
}

65
perl/step3_env.pl
View File

@ -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";
}
}
};
};
}

60
perl/step4_if_fn_do.pl
View File

@ -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";
}
}
};
};
}

65
perl/step5_tco.pl
View File

@ -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";
}
}
};
};
}

69
perl/step6_file.pl
View File

@ -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";
}
}
};
};
}

83
perl/step7_quote.pl
View File

@ -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";
}
}
};
};
}

87
perl/step8_macros.pl
View File

@ -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";
}
}
};
};
}

87
perl/step9_interop.pl
View File

@ -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";
}
}
};
};
}

132
perl/stepA_more.pl
View File

@ -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";
}
}
};
};
}

77
perl/types.pm
View File

@ -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;

2
python/reader.py
View File

@ -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))

13
tests/step6_file.mal
View File

@ -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")

18
tests/stepA_more.mal
View File

@ -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]