Perl: add step4_if_fn_do

- Move string/printing tests to the bottom of tests/step4_if_fn_do

10 files changed, 393 insertions, 141 deletions

diff --git a/docs/step_notes.txt b/docs/step_notes.txt
index 3773517..4e3cd2e 100644
--- a/docs/step_notes.txt
+++ b/docs/step_notes.txt
@@ -89,24 +89,31 @@ Step Notes:
 
 - step3_env
     - types module:
-        - Env type:
-            - find, set, get (no binds/exprs in constructor yet)
         - may need function type if HashMap is strongly typed (e.g. Java)
+    - env type:
+        - find, set, get (no binds/exprs in constructor yet)
     - EVAL/apply:
         - def! - mutate current environment
         - let* - create new environment with bindings
-    - _ref sugar
 
 - step4_if_fn_do
     - types module:
-        - function type (closure)
+        - function type if no closures in impl language
+        - _equal_Q function (recursive)
+    - reader module
+        - string unescaping
+    - printer module
+        - print_readably option for pr_str
         - add function printing to pr_str
+        - string escaping in pr_str
+    - core module (export via core_ns):
+        - export equal_Q from types as =
+        - move arith operations here
+        - add arith comparison functions
+        - pr_str, str, prn, println
+        - list, list?, count, empty?
+    - env module:
         - add binds/exprs handling to Env constructor with variable arity
-        - functions (exported via types_ns):
-            - move arith operations here
-            - comparison operations (including =)
-            - prn, pr_str, = (recursive)
-            - list, list?, count, empty?
     - EVAL:
         - do:
         - if:
@@ -116,10 +123,6 @@ Step Notes:
               have associated metadata
     - define "not" using REP/RE
 
-
-- metadata
-    - 
-
 - step5_tco
     - types module:
         - function type:
diff --git a/js/printer.js b/js/printer.js
index 575072e..5f0e03d 100644
--- a/js/printer.js
+++ b/js/printer.js
@@ -31,7 +31,7 @@ function _pr_str(obj, print_readably) {
         }
         return "{" + ret.join(' ') + "}";
     case 'string':
-        if (print_readably) {
+        if (_r) {
             return '"' + obj.replace(/\\/, "\\\\")
                 .replace(/"/g, '\\"')
                 .replace(/\n/g, "\\n") + '"'; // string
diff --git a/perl/core.pm b/perl/core.pm
new file mode 100644
index 0000000..2f5604b
--- /dev/null
+++ b/perl/core.pm
@@ -0,0 +1,55 @@
+package core;
+use strict;
+use warnings;
+use Exporter 'import';
+our @EXPORT_OK = qw($core_ns);
+
+use types qw(_sequential_Q _equal_Q $nil $true $false _list_Q);
+use printer qw(_pr_str);
+
+use Data::Dumper;
+
+# String functions
+
+sub pr_str {
+    return String->new(join(" ", map {_pr_str($_, 1)} @{$_[0]}));
+}
+
+sub str {
+    return String->new(join("", map {_pr_str($_, 0)} @{$_[0]}));
+}
+
+sub prn {
+    print join(" ", map {_pr_str($_, 1)} @{$_[0]}) . "\n";
+    return $nil
+}
+
+sub println {
+    print join(" ", map {_pr_str($_, 0)} @{$_[0]}) . "\n";
+    return $nil
+}
+
+
+our $core_ns = {
+    '=' =>  sub { _equal_Q($_[0][0], $_[0][1]) ? $true : $false },
+
+    'pr-str' =>  sub { pr_str($_[0]) },
+    'str' =>     sub { str($_[0]) },
+    'prn' =>     sub { prn($_[0]) },
+    'println' => sub { println($_[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]})},
+
+    'list'  => sub { $_[0] },
+    'list?' => sub { _list_Q($_[0][0]) ? $true : $false },
+    'empty?' => sub { scalar(@{$_[0][0]}) == 0 ? $true : $false },
+    'count' => sub { Integer->new(scalar(@{$_[0][0]})) },
+};
+
+1;
diff --git a/perl/env.pm b/perl/env.pm
index 52ee5a1..77d42af 100644
--- a/perl/env.pm
+++ b/perl/env.pm
@@ -11,6 +11,19 @@ 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 "&") {
+                    # variable length arguments
+                    my @earr = @$exprs; # get the array
+                    my @new_arr = @earr[$i..$#earr]; # slice it
+                    $data->{${$binds->[$i+1]}} = List->new(\@new_arr);
+                    last;
+                } else {
+                    $data->{${$binds->[$i]}} = $exprs->[$i];
+                }
+            }
+        }
         bless $data => $class
     }
     sub find {
diff --git a/perl/printer.pm b/perl/printer.pm
index 94219d4..d5bc306 100644
--- a/perl/printer.pm
+++ b/perl/printer.pm
@@ -1,31 +1,42 @@
 package printer;
-use feature qw(switch);
 use strict;
 use warnings;
+use feature qw(switch);
 use Exporter 'import';
 our @EXPORT_OK = qw( _pr_str );
 
 use types qw($nil $true $false);
 
 sub _pr_str {
-    my($obj) = @_;
+    my($obj, $print_readably) = @_;
+    my($_r) = (defined $print_readably) ? $print_readably : 1;
     given (ref $obj) {
         when(/^List/) {
-            return '(' . join(' ', map {_pr_str($_)} @$obj) . ')';
+            return '(' . join(' ', map {_pr_str($_, $_r)} @$obj) . ')';
         }
         when(/^Vector/) {
-            return '[' . join(' ', map {_pr_str($_)} @$obj) . ']';
+            return '[' . join(' ', map {_pr_str($_, $_r)} @$obj) . ']';
         }
         when(/^HashMap/) {
             my @elems = ();
             foreach my $key (keys %$obj) {
-                push(@elems, _pr_str(String->new($key)));
-                push(@elems, _pr_str($obj->{$key}));
+                push(@elems, _pr_str(String->new($key), $_r));
+                push(@elems, _pr_str($obj->{$key}, $_r));
             }
 
             return '{' . join(' ', @elems) . '}';
         }
-        when(/^String/) { return '"' . $$obj . '"'; }
+        when(/^String/) {
+            if ($_r) {
+                my $str = $$obj;
+                $str =~ s/\\/\\\\/g;
+                $str =~ s/"/\\"/g;
+                $str =~ s/\n/\\n"/g;
+                return '"' . $str . '"';
+            } else {
+                return $$obj;
+            }
+        }
         when(/^CODE/)   { return '<builtin_fn* ' . $obj . '>'; }
         default         { return $$obj; }
     }
diff --git a/perl/reader.pm b/perl/reader.pm
index ecbf522..35af099 100644
--- a/perl/reader.pm
+++ b/perl/reader.pm
@@ -30,7 +30,12 @@ sub read_atom {
     my $token = $rdr->next();
     given ($token) {
         when(/^-?[0-9]+$/) { return Integer->new($token) }
-        when(/^"/) { return String->new(substr $token, 1, -1) }
+        when(/^"/) {
+            my $str = substr $token, 1, -1;
+            $str =~ s/\\"/"/g;
+            $str =~ s/\\n/\n/g;
+            return String->new($str)
+        }
         when(/^nil$/) { return $nil }
         when(/^true$/) { return $true }
         when(/^false$/) { return $false }
diff --git a/perl/step1_read_print.pl b/perl/step1_read_print.pl
index 8d96ab5..48c31ec 100644
--- a/perl/step1_read_print.pl
+++ b/perl/step1_read_print.pl
@@ -3,13 +3,13 @@ use warnings;
 use readline qw(readline);
 use feature qw(switch);
 
-use reader qw(read_str);
-use printer qw(_pr_str);
+use reader;
+use printer;
 
 # read
 sub READ {
     my $str = shift;
-    return read_str($str);
+    return reader::read_str($str);
 }
 
 # eval
@@ -21,7 +21,7 @@ sub EVAL {
 # print
 sub PRINT {
     my $exp = shift;
-    return _pr_str($exp);
+    return printer::_pr_str($exp);
 }
 
 # repl
diff --git a/perl/step4_if_fn_do.pl b/perl/step4_if_fn_do.pl
new file mode 100644
index 0000000..7f7e1ab
--- /dev/null
+++ b/perl/step4_if_fn_do.pl
@@ -0,0 +1,115 @@
+use strict;
+use warnings;
+use readline qw(readline);
+use feature qw(switch);
+use Data::Dumper;
+
+use types qw($nil $true $false);
+use reader;
+use printer;
+use env;
+use core qw($core_ns);
+
+# read
+sub READ {
+    my $str = shift;
+    return reader::read_str($str);
+}
+
+# eval
+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) = @_;
+    #print "EVAL: " . printer::_pr_str($ast) . "\n";
+    if (! ((ref $ast) =~ /^List/)) {
+        return eval_ast($ast, $env);
+    }
+
+    # apply list
+    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 (/^do$/) {
+            my $el = eval_ast($ast->rest(), $env);
+            return $el->[$#{$el}];
+        }
+        when (/^if$/) {
+            my $cond = EVAL($a1, $env);
+            if ($cond eq $nil || $cond eq $false) {
+                return $a3 ? EVAL($a3, $env) : $nil;
+            } else {
+                return EVAL($a2, $env);
+            }
+        }
+        when (/^fn\*$/) {
+            return sub {
+                #print "running fn*\n";
+                my $args = $_[0];
+                return EVAL($a2, Env->new($env, $a1, $args));
+            };
+        }
+        default {
+            my $el = eval_ast($ast, $env);
+            my $f = $el->[0];
+            return &{ $f }($el->rest());
+        }
+    }
+}
+
+# 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}); }
+
+# core.mal: defined using the language itself
+REP("(def! not (fn* (a) (if a false true)))");
+
+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 054c303..44be6b9 100644
--- a/perl/types.pm
+++ b/perl/types.pm
@@ -1,8 +1,51 @@
 package types;
 use strict;
 use warnings;
+use feature qw(switch);
 use Exporter 'import';
-our @EXPORT_OK = qw( $nil $true $false);
+our @EXPORT_OK = qw(_sequential_Q _equal_Q
+                    $nil $true $false
+                    _list_Q);
+
+use Data::Dumper;
+
+# General functions
+
+sub _sequential_Q {
+    return _list_Q($_[0]) || _vector_Q($_[0])
+}
+
+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;
+    }
+    given (ref $a) {
+        when (/^Symbol/) {
+            return $$a eq $$b;
+        }
+        when (/^List/ || /^Vector/) {
+            if (! scalar(@$a) == scalar(@$b)) {
+                return 0;
+            }
+            for (my $i=0; $i<scalar(@$a); $i++) {
+                if (! _equal_Q($a->[$i], $b->[$i])) {
+                    return 0;
+                }
+            }
+            return 1;
+        }
+        default {
+            return $$a eq $$b;
+        }
+    }
+    return 0;
+}
+
+# Scalars
 
 {
     package Nil;
@@ -41,21 +84,28 @@ sub _symbol_Q { ref $_[0] =~ /^Symbol/ }
 }
 
 
+# Lists
+
 {
     package List;
-    use Data::Dumper;
     sub new  { my $class = shift; bless $_[0], $class }
     sub rest { my @arr = @{$_[0]}; List->new([@arr[1..$#arr]]); }
 }
 
-sub _list_Q { ref $_[0] =~ /^Symbol/ }
+sub _list_Q { (ref $_[0]) =~ /^List/ }
+
 
+# Vectors
 
 {
     package Vector;
     sub new  { my $class = shift; bless $_[0], $class }
 }
 
+sub _vector_Q { (ref $_[0]) =~ /^Vector/ }
+
+
+# Hash Maps
 
 {
     package HashMap;
diff --git a/tests/step4_if_fn_do.mal b/tests/step4_if_fn_do.mal
index 32d2d66..3e1c016 100644
--- a/tests/step4_if_fn_do.mal
+++ b/tests/step4_if_fn_do.mal
@@ -1,117 +1,5 @@
 ;; -----------------------------------------------------
 
-;; Testing string quoting
-
-""
-;=>""
-
-"abc"
-;=>"abc"
-
-"abc  def"
-;=>"abc  def"
-
-"\""
-;=>"\""
-
-
-;; Testing pr-str
-
-(pr-str)
-;=>""
-
-(pr-str "")
-;=>"\"\""
-
-(pr-str "abc")
-;=>"\"abc\""
-
-(pr-str "abc  def" "ghi jkl")
-;=>"\"abc  def\" \"ghi jkl\""
-
-(pr-str "\"")
-;=>"\"\\\"\""
-
-(pr-str (list 1 2 "abc" "\"") "def")
-;=>"(1 2 \"abc\" \"\\\"\") \"def\""
-
-
-;; Testing str
-
-(str)
-;=>""
-
-(str "")
-;=>""
-
-(str "abc")
-;=>"abc"
-
-(str "\"")
-;=>"\""
-
-(str 1 "abc" 3)
-;=>"1abc3"
-
-(str "abc  def" "ghi jkl")
-;=>"abc  defghi jkl"
-
-;;; TODO: get this working properly
-;;;(str (list 1 2 "abc" "\"") "def")
-;;;;=>"(1 2 \"abc\" \"\\\"\")def"
-
-
-;; Testing prn
-(prn)
-; 
-;=>nil
-
-(prn "")
-; ""
-;=>nil
-
-(prn "abc")
-; "abc"
-;=>nil
-
-(prn "abc  def" "ghi jkl")
-; "abc  def" "ghi jkl"
-
-(prn "\"")
-; "\""
-;=>nil
-
-(prn (list 1 2 "abc" "\"") "def")
-; (1 2 "abc" "\"") "def"
-;=>nil
-
-
-;; Testing println
-(println)
-; 
-;=>nil
-
-(println "")
-; 
-;=>nil
-
-(println "abc")
-; abc
-;=>nil
-
-(println "abc  def" "ghi jkl")
-; abc  def ghi jkl
-
-(println "\"")
-; "
-;=>nil
-
-(println (list 1 2 "abc" "\"") "def")
-; (1 2 abc ") def
-;=>nil
-
-;; -----------------------------------------------------
-
 
 ;; Testing list functions
 (list)
@@ -328,6 +216,118 @@ a
 (fib 10)
 ;=>89
 
+;; -----------------------------------------------------
+
+;; Testing string quoting
+
+""
+;=>""
+
+"abc"
+;=>"abc"
+
+"abc  def"
+;=>"abc  def"
+
+"\""
+;=>"\""
+
+
+;; Testing pr-str
+
+(pr-str)
+;=>""
+
+(pr-str "")
+;=>"\"\""
+
+(pr-str "abc")
+;=>"\"abc\""
+
+(pr-str "abc  def" "ghi jkl")
+;=>"\"abc  def\" \"ghi jkl\""
+
+(pr-str "\"")
+;=>"\"\\\"\""
+
+(pr-str (list 1 2 "abc" "\"") "def")
+;=>"(1 2 \"abc\" \"\\\"\") \"def\""
+
+
+;; Testing str
+
+(str)
+;=>""
+
+(str "")
+;=>""
+
+(str "abc")
+;=>"abc"
+
+(str "\"")
+;=>"\""
+
+(str 1 "abc" 3)
+;=>"1abc3"
+
+(str "abc  def" "ghi jkl")
+;=>"abc  defghi jkl"
+
+;;; TODO: get this working properly
+;;;(str (list 1 2 "abc" "\"") "def")
+;;;;=>"(1 2 \"abc\" \"\\\"\")def"
+
+
+;; Testing prn
+(prn)
+; 
+;=>nil
+
+(prn "")
+; ""
+;=>nil
+
+(prn "abc")
+; "abc"
+;=>nil
+
+(prn "abc  def" "ghi jkl")
+; "abc  def" "ghi jkl"
+
+(prn "\"")
+; "\""
+;=>nil
+
+(prn (list 1 2 "abc" "\"") "def")
+; (1 2 "abc" "\"") "def"
+;=>nil
+
+
+;; Testing println
+(println)
+; 
+;=>nil
+
+(println "")
+; 
+;=>nil
+
+(println "abc")
+; abc
+;=>nil
+
+(println "abc  def" "ghi jkl")
+; abc  def ghi jkl
+
+(println "\"")
+; "
+;=>nil
+
+(println (list 1 2 "abc" "\"") "def")
+; (1 2 abc ") def
+;=>nil
+
 ;;
 ;; -------- Optional Functionality --------