Perl: add stepA_more.

7 files changed, 359 insertions, 23 deletions

diff --git a/docs/step_notes.txt b/docs/step_notes.txt
index 06994e3..79036a8 100644
--- a/docs/step_notes.txt
+++ b/docs/step_notes.txt
@@ -176,6 +176,8 @@ Step Notes:
         - set ismacro property on function
 
 - step9_interop
+    - convert returned data to mal data
+        - recursive, similar to pr_str
 
 - stepA_more
     - core module:
@@ -183,16 +185,16 @@ Step Notes:
         - apply, map functions: should not directly call EVAL, which
           requires the function object to be runnable
         - readline
+        - nil?, true?, false? 
     - EVAL:
         - try*/catch*: for normal exceptions, extracts string
           otherwise extracts full value
     - set and print *host-language*
+    - define cond and or macros using REP/RE
 
 - Extra defintions needed for self-hosting
-    - types module:
-        - symbol?, nil?, true?, false?, sequential? (if not already)
-        - first, rest
-    - define cond and or macros using REP/RE
+    - core module:
+        - symbol?, sequential? (if not already)
 
 - Other misc:
     - conj function
diff --git a/perl/core.pm b/perl/core.pm
index 5b372a1..bbdab9a 100644
--- a/perl/core.pm
+++ b/perl/core.pm
@@ -4,7 +4,10 @@ use warnings FATAL => qw(all);
 use Exporter 'import';
 our @EXPORT_OK = qw($core_ns);
 
-use types qw(_sequential_Q _equal_Q $nil $true $false _list_Q);
+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 reader qw(read_str);
 use printer qw(_pr_str);
 
@@ -30,6 +33,11 @@ sub println {
     return $nil
 }
 
+sub mal_readline {
+    my $line = readline(${$_[0]});
+    return $line ? String->new($line) : $nil;
+}
+
 sub slurp {
     my ($fname) = ${$_[0]}; 
     open my $F, '<', $fname or die "error opening '$fname'";
@@ -37,8 +45,45 @@ sub slurp {
     String->new($data)
 }
 
+# Hash Map functions
+
+sub assoc {
+    my $src_hsh = shift;
+    my $new_hsh = { %$src_hsh };
+    return _assoc_BANG($new_hsh, @_);
+}
+
+sub dissoc {
+    my $src_hsh = shift;
+    my $new_hsh = { %$src_hsh };
+    return _dissoc_BANG($new_hsh, @_);
+}
 
-# List functions
+
+sub get {
+    my ($hsh, $key) = @_;
+    return $nil if $hsh eq $nil;
+    return exists $hsh->{$$key} ? $hsh->{$$key} : $nil;
+}
+
+sub contains_Q {
+    my ($hsh, $key) = @_;
+    return $nil if $hsh eq $false;
+    return (exists $hsh->{$$key}) ? $true : $false;
+}
+
+sub mal_keys {
+    my @ks = map { String->new($_) } keys %{$_[0]};
+    return List->new(\@ks);
+}
+
+sub mal_vals {
+    my @vs = values %{$_[0]};
+    return List->new(\@vs);
+}
+
+
+# Sequence functions
 
 sub cons {
     my ($a, $b) = @_;
@@ -61,17 +106,47 @@ sub first { my ($seq) = @_; return scalar(@$seq) > 0 ? $seq->[0] : $nil; }
 
 sub rest { return $_[0]->rest(); }
 
+sub apply {
+    my @all_args = @{$_[0]};
+    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]};
+    if ((ref $f) =~ /^Function/) {
+        return $f->apply(List->new(\@args));
+    } else {
+        return &{ $f }(List->new(\@args));
+    }
+}
+
+sub mal_map {
+    my $f = shift;
+    my @arr;
+    if ((ref $f) =~ /^Function/) {
+        @arr = map { $f->apply(List->new([$_])) } @{$_[0]};
+    } else {
+        @arr = map { &{ $f}(List->new([$_])) } @{$_[0]};
+    }
+    return List->new(\@arr);
+}
+
 
 
 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 },
 
     '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]) },
+    '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 },
@@ -83,7 +158,16 @@ our $core_ns = {
 
     '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]}) },
+
+    '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]) },
@@ -91,6 +175,8 @@ our $core_ns = {
     'concat' => sub { concat(@{$_[0]}) },
     'empty?' => sub { scalar(@{$_[0][0]}) == 0 ? $true : $false },
     'count' => sub { Integer->new(scalar(@{$_[0][0]})) },
+    'apply' => sub { apply($_[0]) },
+    'map' => sub { mal_map($_[0][0], $_[0][1]) },
 };
 
 1;
diff --git a/perl/env.pm b/perl/env.pm
index 77d42af..1d75460 100644
--- a/perl/env.pm
+++ b/perl/env.pm
@@ -40,7 +40,7 @@ use Data::Dumper;
     sub get {
         my ($self, $key) = @_;
         my $env = $self->find($key);
-        die "'" . $key . "' not found" unless $env;
+        die "'" . $key . "' not found\n" unless $env;
         return $env->{$key};
     }
 }
diff --git a/perl/reader.pm b/perl/reader.pm
index e173910..cd1e19d 100644
--- a/perl/reader.pm
+++ b/perl/reader.pm
@@ -5,7 +5,7 @@ use warnings FATAL => qw(all);
 use Exporter 'import';
 our @EXPORT_OK = qw( read_str );
 
-use types qw($nil $true $false);
+use types qw($nil $true $false _hash_map);
 
 use Data::Dumper;
 
@@ -65,12 +65,7 @@ sub read_list {
     } elsif ($class eq 'Vector') {
         return Vector->new(\@lst);
     } else {
-        my $hsh = {};
-        for(my $i=0; $i<$#lst; $i+=2) {
-            my $str = $lst[$i];
-            $hsh->{$$str} = $lst[$i+1];
-        }
-        return HashMap->new($hsh);
+        return _hash_map(@lst);
     }
 }
 
diff --git a/perl/stepA_more.pl b/perl/stepA_more.pl
new file mode 100644
index 0000000..ae42a2d
--- /dev/null
+++ b/perl/stepA_more.pl
@@ -0,0 +1,217 @@
+use strict;
+use warnings FATAL => qw(all);
+use readline qw(readline);
+use feature qw(switch);
+use Data::Dumper;
+
+use types qw($nil $true $false _sequential_Q _symbol_Q _list_Q);
+use reader;
+use printer;
+use env;
+use core qw($core_ns);
+use interop qw(pl_to_mal);
+
+# read
+sub READ {
+    my $str = shift;
+    return reader::read_str($str);
+}
+
+# eval
+sub is_pair {
+    my ($x) = @_;
+    return _sequential_Q($x) && scalar(@$x) > 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') {
+        return List->new([Symbol->new("concat"),
+                          $ast->[0][1],
+                          quasiquote($ast->rest())]);
+    } else {
+        return List->new([Symbol->new("cons"),
+                          quasiquote($ast->[0]),
+                          quasiquote($ast->rest())]);
+    }
+}
+
+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]});
+        if ((ref $f) =~ /^Function/) {
+            return $f->{ismacro};
+        }
+    }
+    return 0;
+}
+
+sub macroexpand {
+    my ($ast, $env) = @_;
+    while (is_macro_call($ast, $env)) {
+        my $mac = $env->get(${$ast->[0]});
+        $ast = $mac->apply($ast->rest());
+    }
+    return $ast;
+}
+
+
+sub eval_ast {
+    my($ast, $env) = @_;
+    given (ref $ast) {
+        when (/^Symbol/) {
+            $env->get($$ast);
+        }
+        when (/^List/) {
+            my @lst = map {EVAL($_, $env)} @$ast;
+            return List->new(\@lst);
+        }
+        default {
+            return $ast;
+        }
+    }
+}
+
+sub EVAL {
+    my($ast, $env) = @_;
+
+    while (1) {
+
+    #print "EVAL: " . printer::_pr_str($ast) . "\n";
+    if (! _list_Q($ast)) {
+        return eval_ast($ast, $env);
+    }
+
+    # apply list
+    $ast = macroexpand($ast, $env);
+    if (! _list_Q($ast)) { return $ast; }
+
+    my ($a0, $a1, $a2, $a3) = @$ast;
+    given ((ref $a0) =~ /^Symbol/ ? $$a0 : $a0) {
+        when (/^def!$/) {
+            my $res = EVAL($a2, $env);
+            return $env->set($$a1, $res);
+        }
+        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));
+            }
+            return EVAL($a2, $let_env);
+        }
+        when (/^quote$/) {
+            return $a1;
+        }
+        when (/^quasiquote$/) {
+            return EVAL(quasiquote($a1), $env);
+        }
+        when (/^defmacro!$/) {
+            my $func = EVAL($a2, $env);
+            $func->{ismacro} = 1;
+            return $env->set($$a1, $func);
+        }
+        when (/^macroexpand$/) {
+            return macroexpand($a1, $env);
+        }
+        when (/^pl\*$/) {
+            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;
+                    } else {
+                        $exc = String->new(substr $err, 0, -1);
+                    }
+                    return EVAL($a2->[2], Env->new($env,
+                                                   List->new([$a2->[1]]), 
+                                                   List->new([$exc])));
+                } else {
+                    die $err;
+                }
+            }
+        }
+        when (/^do$/) {
+            eval_ast($ast->slice(1, $#{$ast}-1), $env);
+            $ast = $ast->[$#{$ast}];
+        }
+        when (/^if$/) {
+            my $cond = EVAL($a1, $env);
+            if ($cond eq $nil || $cond eq $false) {
+                $ast = $a3 ? $a3 : $nil;
+            } else {
+                $ast = $a2;
+            }
+        }
+        when (/^fn\*$/) {
+            return Function->new(\&EVAL, $a2, $env, $a1);
+        }
+        default {
+            my $el = eval_ast($ast, $env);
+            my $f = $el->[0];
+            if ((ref $f) =~ /^Function/) {
+                $ast = $f->{ast};
+                $env = $f->gen_env($el->rest());
+            } else {
+                return &{ $f }($el->rest());
+            }
+        }
+    }
+
+    } # TCO while loop
+}
+
+# print
+sub PRINT {
+    my $exp = shift;
+    return printer::_pr_str($exp);
+}
+
+# repl
+my $repl_env = Env->new();
+sub REP {
+    my $str = shift;
+    return PRINT(EVAL(READ($str), $repl_env));
+}
+
+# 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); });
+my @_argv = map {String->new($_)}  @ARGV[1..$#ARGV];
+$repl_env->set('*ARGV*', List->new(\@_argv));
+
+# core.mal: defined using the language itself
+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) {
+    REP("(load-file \"" . $ARGV[0] . "\")");
+    exit 0;
+}
+while (1) {
+    my $line = 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";
+    }
+}
diff --git a/perl/types.pm b/perl/types.pm
index e661319..785c321 100644
--- a/perl/types.pm
+++ b/perl/types.pm
@@ -5,7 +5,8 @@ use feature qw(switch);
 use Exporter 'import';
 our @EXPORT_OK = qw(_sequential_Q _equal_Q
                     $nil $true $false
-                    _symbol_Q _list_Q);
+                    _symbol_Q _nil_Q _true_Q _false_Q _list_Q
+                    _hash_map _hash_map_Q _assoc_BANG _dissoc_BANG);
 
 use Data::Dumper;
 
@@ -62,6 +63,11 @@ our $nil =   Nil->new();
 our $true =  True->new();
 our $false = False->new();
 
+sub _nil_Q   { return $_[0] eq $nil }
+sub _true_Q  { return $_[0] eq $true }
+sub _false_Q { return $_[0] eq $false }
+
+
 {
     package Integer;
     sub new  { my $class = shift; bless \$_[0] => $class }
@@ -113,6 +119,33 @@ sub _vector_Q { (ref $_[0]) =~ /^Vector/ }
     sub new  { my $class = shift; bless $_[0], $class }
 }
 
+sub _hash_map {
+    my $hsh = {};
+    return _assoc_BANG($hsh, @_);
+}
+
+sub _assoc_BANG {
+    my $hsh = shift;
+    my @lst = @_;
+    for(my $i=0; $i<scalar(@lst); $i+=2) {
+        my $str = $lst[$i];
+        $hsh->{$$str} = $lst[$i+1];
+    }
+    return HashMap->new($hsh);
+}
+
+sub _dissoc_BANG {
+    my $hsh = shift;
+    my @lst = @_;
+    for(my $i=0; $i<scalar(@lst); $i++) {
+        my $str = $lst[$i];
+        delete $hsh->{$$str};
+    }
+    return HashMap->new($hsh);
+}
+
+sub _hash_map_Q { (ref $_[0]) =~ /^HashMap/ }
+
 
 # Functions
 
diff --git a/tests/stepA_more.mal b/tests/stepA_more.mal
index 2ca58fb..4d2acf9 100644
--- a/tests/stepA_more.mal
+++ b/tests/stepA_more.mal
@@ -1,14 +1,17 @@
 ;;
 ;; Testing try*/catch*
 
-(try* (abc 1 2) (catch* exc (prn exc))))
-; "'abc' not found"
+(try* (abc 1 2) (catch* exc (prn "exc is:" exc))))
+; "exc is:" "'abc' not found"
 ;=>nil
 
-;;;TODO: fix so long lines don't trigger ANSI escape codes
-;;;(try* (throw {"data" "foo"}) (catch* exc (do (prn "exc is:" exc) 7)))
-;;;; "exc is:" {"data" "foo"}
-;;;;=>7
+;;;TODO: fix so long lines don't trigger ANSI escape codes ;;;(try*
+(throw {"data" "foo"}) (catch* exc (do (prn "exc is:" exc) 7))) ;;;;
+"exc is:" {"data" "foo"} ;;;;=>7
+
+(try* (throw {"data" "foo"}) (catch* exc (do (prn "err:" exc) 7)))
+; "err:" {"data" "foo"}
+;=>7
 
 (try* (throw "my exception") (catch* exc (do (prn "exc:" exc) 7)))
 ; "exc:" "my exception"