Perl: step8_macros

- Fixes to core.pl: concat
- Fixes to types.pl: _symbol_Q, Function apply

diff --git a/docs/step_notes.txt b/docs/step_notes.txt
index 897fb56..06994e3 100644 (file)
--- a/docs/step_notes.txt
+++ b/docs/step_notes.txt
@@ -162,16 +162,18 @@ Step Notes:
           splice-unquote and quasiquote
 
 - step8_macros
-    - types module:
-        - add first, rest functions
+    - types
+        - capability to store ismacro property in function
+    - core module:
+        - add first, rest, nth functions
     - add is_macro_call and macroexpand
         - recursively macroexpand lists
         - if applying a macro function, run it on the ast first before
           continuing
-    - call macroexpand apply in EVAL
+    - call macroexpand apply in EVAL before apply
     - EVAL:
         - add 'defmacro!' and 'macroexpand'
-        - store ismacro property on function metadata
+        - set ismacro property on function
 
 - step9_interop
 

diff --git a/perl/core.pm b/perl/core.pm
index a243dcb..5b372a1 100644 (file)
--- a/perl/core.pm
+++ b/perl/core.pm
@@ -48,12 +48,20 @@ sub cons {
 }
 
 sub concat {
-    my ($a, $b) = @_;
+    if (scalar(@_) == 0) { return List->new([]); }
+    my ($a) = shift;
     my @new_arr = @{$a};
-    push @new_arr, @$b;
+    map { push @new_arr, @$_ } @_;
     List->new(\@new_arr);
 }
 
+sub nth { my ($seq,$i) = @_; return scalar(@$seq) > $i ? $seq->[$i] : $nil; }
+
+sub first { my ($seq) = @_; return scalar(@$seq) > 0 ? $seq->[0] : $nil; }
+
+sub rest { return $_[0]->rest(); }
+
+
 
 our $core_ns = {
     '=' =>  sub { _equal_Q($_[0][0], $_[0][1]) ? $true : $false },
@@ -76,8 +84,11 @@ our $core_ns = {
     'list'  => sub { $_[0] },
     'list?' => sub { _list_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][0], $_[0][1]) },
+    'concat' => sub { concat(@{$_[0]}) },
     'empty?' => sub { scalar(@{$_[0][0]}) == 0 ? $true : $false },
     'count' => sub { Integer->new(scalar(@{$_[0][0]})) },
 };

diff --git a/perl/step7_quote.pl b/perl/step7_quote.pl
index 7b9f92f..c1f64f4 100644 (file)
--- a/perl/step7_quote.pl
+++ b/perl/step7_quote.pl
@@ -4,7 +4,7 @@ use readline qw(readline);
 use feature qw(switch);
 use Data::Dumper;
 
-use types qw($nil $true $false _sequential_Q);
+use types qw($nil $true $false _sequential_Q _symbol_Q);
 use reader;
 use printer;
 use env;
@@ -26,11 +26,9 @@ sub quasiquote {
     my ($ast) = @_;
     if (!is_pair($ast)) {
         return List->new([Symbol->new("quote"), $ast]);
-    } elsif (((ref $ast->[0]) =~ /^Symbol/) &&
-             ${$ast->[0]} eq 'unquote') {
+    } elsif (_symbol_Q($ast->[0]) && ${$ast->[0]} eq 'unquote') {
         return $ast->[1];
-    } elsif (is_pair($ast->[0]) &&
-             ((ref $ast->[0][0]) =~ /^Symbol/) &&
+    } 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],

diff --git a/perl/step8_macros.pl b/perl/step8_macros.pl
new file mode 100644 (file)
index 0000000..81c7671
--- /dev/null
+++ b/perl/step8_macros.pl
@@ -0,0 +1,192 @@
+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);
+
+# 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 (/^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 83da6e2..e661319 100644 (file)
--- a/perl/types.pm
+++ b/perl/types.pm
@@ -5,7 +5,7 @@ use feature qw(switch);
 use Exporter 'import';
 our @EXPORT_OK = qw(_sequential_Q _equal_Q
                     $nil $true $false
-                    _list_Q);
+                    _symbol_Q _list_Q);
 
 use Data::Dumper;
 
@@ -18,8 +18,6 @@ sub _sequential_Q {
 sub _equal_Q {
     my ($a, $b) = @_;
     my ($ota, $otb) = (ref $a, ref $b);
-    #my $ota = ref $a;
-    #my $otb = ref $b;
     if (!(($ota eq $otb) || (_sequential_Q($a) && _sequential_Q($b)))) {
         return 0;
     }
@@ -75,7 +73,7 @@ our $false = False->new();
     sub new  { my $class = shift; bless \$_[0] => $class }
 }
 
-sub _symbol_Q { ref $_[0] =~ /^Symbol/ }
+sub _symbol_Q { (ref $_[0]) =~ /^Symbol/ }
 
 
 {
@@ -101,6 +99,8 @@ 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 _vector_Q { (ref $_[0]) =~ /^Vector/ }
@@ -124,15 +124,16 @@ sub _vector_Q { (ref $_[0]) =~ /^Vector/ }
         bless {'eval'=>$eval,
                'ast'=>$ast,
                'env'=>$env,
-               'params'=>$params}, $class
+               'params'=>$params,
+               'ismacro'=>0}, $class
     }
     sub gen_env {
-        my %self = %{$_[0]};
-        return Env->new($self{env}, $self{params}, $_[1]);
+        my $self = $_[0];
+        return Env->new($self->{env}, $self->{params}, $_[1]);
     }
     sub apply {
-        my %self = %{$_[0]};
-        return &{ $self{eval} }($self{ast}, gen_env($_[1]));
+        my $self = $_[0];
+        return &{ $self->{eval} }($self->{ast}, gen_env($self, $_[1]));
     }
 }