Perl: step6_file

diff --git a/docs/step_notes.txt b/docs/step_notes.txt
index 4bdbb61..897fb56 100644 (file)
--- a/docs/step_notes.txt
+++ b/docs/step_notes.txt
@@ -142,9 +142,12 @@ Step Notes:
               on the function
 
 - step6_file
-    - add read-string, eval, slurp platform wrappers
-    - define load-file function
-    - if files on command line, use load-file to run
+    - core module:
+        - read-string, slurp functions
+    - define eval and load-file functions
+    - set *ARGV*
+    - if files on command line, use load-file to run first argument
+      using rest as arguments
 
 - step7_quote
     - add is_pair and quasiquote functions
@@ -152,7 +155,7 @@ Step Notes:
         - if vectors, use sequential? instead of list? in is_pair
     - EVAL:
         - add 'quote', 'quasiquote' cases
-    - types module:
+    - core module:
         - add cons and concat functions
     - reader module:
         - add reader macros to read_form for quote, unquote,
@@ -173,13 +176,15 @@ Step Notes:
 - step9_interop
 
 - stepA_more
-    - types module:
+    - core module:
         - throw function
         - apply, map functions: should not directly call EVAL, which
           requires the function object to be runnable
+        - readline
     - EVAL:
         - try*/catch*: for normal exceptions, extracts string
           otherwise extracts full value
+    - set and print *host-language*
 
 - Extra defintions needed for self-hosting
     - types module:

diff --git a/perl/core.pm b/perl/core.pm
index 3f2215e..a529d21 100644 (file)
--- a/perl/core.pm
+++ b/perl/core.pm
@@ -5,6 +5,7 @@ use Exporter 'import';
 our @EXPORT_OK = qw($core_ns);
 
 use types qw(_sequential_Q _equal_Q $nil $true $false _list_Q);
+use reader qw(read_str);
 use printer qw(_pr_str);
 
 use Data::Dumper;
@@ -29,6 +30,13 @@ sub println {
     return $nil
 }
 
+sub slurp {
+    my ($fname) = ${$_[0]}; 
+    open my $F, '<', $fname or die "error opening '$fname'";
+    my $data = do { local $/; <$F> };
+    String->new($data)
+}
+
 
 our $core_ns = {
     '=' =>  sub { _equal_Q($_[0][0], $_[0][1]) ? $true : $false },
@@ -37,6 +45,8 @@ our $core_ns = {
     'str' =>     sub { str($_[0]) },
     'prn' =>     sub { prn($_[0]) },
     'println' => sub { println($_[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 },

diff --git a/perl/printer.pm b/perl/printer.pm
index 7880798..4240ff0 100644 (file)
--- a/perl/printer.pm
+++ b/perl/printer.pm
@@ -31,7 +31,7 @@ sub _pr_str {
                 my $str = $$obj;
                 $str =~ s/\\/\\\\/g;
                 $str =~ s/"/\\"/g;
-                $str =~ s/\n/\\n"/g;
+                $str =~ s/\n/\\n/g;
                 return '"' . $str . '"';
             } else {
                 return $$obj;

diff --git a/perl/step6_file.pl b/perl/step6_file.pl
new file mode 100644 (file)
index 0000000..4606297
--- /dev/null
+++ b/perl/step6_file.pl
@@ -0,0 +1,129 @@
+use strict;
+use warnings FATAL => qw(all);
+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) = @_;
+
+    while (1) {
+
+    #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$/) {
+            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";
+    }
+}