diff options
| -rw-r--r-- | Makefile | 4 | ||||
| -rw-r--r-- | docs/TODO | 3 | ||||
| -rw-r--r-- | perl/printer.pm | 33 | ||||
| -rw-r--r-- | perl/reader.pm | 102 | ||||
| -rw-r--r-- | perl/step1_read_print.pl | 45 | ||||
| -rw-r--r-- | perl/types.pm | 55 |
6 files changed, 241 insertions, 1 deletions
@@ -10,7 +10,7 @@ PYTHON = python # Settings # -IMPLS = bash c clojure cs java js make mal php ps python ruby +IMPLS = bash c clojure cs java js make mal perl php ps python ruby step0 = step0_repl step1 = step1_read_print @@ -41,6 +41,7 @@ java_STEP_TO_PROG = java/src/main/java/mal/$($(1)).java js_STEP_TO_PROG = js/$($(1)).js make_STEP_TO_PROG = make/$($(1)).mk mal_STEP_TO_PROG = mal/$($(1)).mal +perl_STEP_TO_PROG = perl/$($(1)).pl php_STEP_TO_PROG = php/$($(1)).php ps_STEP_TO_PROG = ps/$($(1)).ps python_STEP_TO_PROG = python/$($(1)).py @@ -55,6 +56,7 @@ java_RUNSTEP = mvn -quiet exec:java -Dexec.mainClass="mal.$($(1))" -Dexec.arg js_RUNSTEP = node ../$(2) $(3) make_RUNSTEP = make -f ../$(2) $(3) mal_RUNSTEP = $(call $(MAL_IMPL)_RUNSTEP,$(1),$(call $(MAL_IMPL)_STEP_TO_PROG,stepA),../$(2),") #" +perl_RUNSTEP = perl ../$(2) $(3) php_RUNSTEP = php ../$(2) $(3) ps_RUNSTEP = $(4)gs -q -dNODISPLAY -- ../$(2) $(3)$(4) python_RUNSTEP = $(PYTHON) ../$(2) $(3) @@ -41,6 +41,9 @@ Mal: - step5_tco - step9_interop +Perl: + - object exceptions: http://perldoc.perl.org/functions/die.html + PHP: Postscript: diff --git a/perl/printer.pm b/perl/printer.pm new file mode 100644 index 0000000..9741eda --- /dev/null +++ b/perl/printer.pm @@ -0,0 +1,33 @@ +package printer; +use feature qw(switch); +use strict; +use warnings; +use Exporter 'import'; +our @EXPORT_OK = qw( _pr_str ); + +use types qw($nil $true $false); + +sub _pr_str { + my($obj) = @_; + given (ref $obj) { + when(/^List/) { + return '(' . join(' ', map {_pr_str($_)} @$obj) . ')'; + } + when(/^Vector/) { + return '[' . join(' ', map {_pr_str($_)} @$obj) . ']'; + } + when(/^HashMap/) { + my @elems = (); + foreach my $key (keys %$obj) { + push(@elems, _pr_str(String->new($key))); + push(@elems, _pr_str($obj->{$key})); + } + + return '{' . join(' ', @elems) . '}'; + } + when(/^String/) { return '"' . $$obj . '"'; } + default { return $$obj; } + } +} + +1; diff --git a/perl/reader.pm b/perl/reader.pm new file mode 100644 index 0000000..52b1a76 --- /dev/null +++ b/perl/reader.pm @@ -0,0 +1,102 @@ +package reader; +use feature qw(switch); +use strict; +use warnings; +use Exporter 'import'; +our @EXPORT_OK = qw( read_str ); + +use types qw($nil $true $false); + +use Data::Dumper; + +{ + package Reader; + sub new { + my $class = shift; + bless { position => 0, tokens => shift } => $class + } + sub next { my $self = shift; return $self->{tokens}[$self->{position}++] } + sub peek { my $self = shift; return $self->{tokens}[$self->{position}] } +} + +sub tokenize { + my($str) = @_; + my @tokens = $str =~ /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/g; + return grep {not /^;|^$/} @tokens; +} + +sub read_atom { + my($rdr) = @_; + my $token = $rdr->next(); + given ($token) { + when(/^-?[0-9]+$/) { return Integer->new($token) } + when(/^"/) { return String->new(substr $token, 1, -1) } + when(/^nil$/) { return $nil } + when(/^true$/) { return $true } + when(/^false$/) { return $false } + default { return Symbol->new($token) } + } +} + +sub read_list { + my($rdr,$class,$start,$end) = @_; + $start = $start || '('; + $end = $end || ')'; + + my $token = $rdr->next(); + my @lst = (); + if ($token ne $start) { + die "expected '$start'"; + } + while (($token = $rdr->peek()) ne $end) { + if (! defined $token) { + die "expected '$end', got EOF"; + } + push(@lst, read_form($rdr)); + } + $rdr->next(); + if ($class eq 'List') { + return List->new(\@lst); + } 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); + } +} + +sub read_form { + my($rdr) = @_; + my $token = $rdr->peek(); + given ($token) { + when(')') { die "unexpected ')'"; } + when('(') { return read_list($rdr, 'List'); } + when(']') { die "unexpected ']'"; } + when('[') { return read_list($rdr, 'Vector', '[', ']'); } + when('}') { die "unexpected '}'"; } + when('{') { return read_list($rdr, 'HashMap', '{', '}'); } + default { return read_atom($rdr); } + } +} + +sub read_str { + my($str) = @_; + my @tokens = tokenize($str); + #print join(" / ", @tokens) . "\n"; + return read_form(Reader->new(\@tokens)); +} + +#print Dumper(read_str("123")); +#print Dumper(read_str("+")); +#print Dumper(read_str("\"abc\"")); +#print Dumper(read_str("nil")); +#print Dumper(read_str("true")); +#print Dumper(read_str("false")); +#print Dumper(read_str("(+ 2 3)")); +#print Dumper(read_str("(foo 2 (3 4))")); + +1; diff --git a/perl/step1_read_print.pl b/perl/step1_read_print.pl new file mode 100644 index 0000000..8d96ab5 --- /dev/null +++ b/perl/step1_read_print.pl @@ -0,0 +1,45 @@ +use strict; +use warnings; +use readline qw(readline); +use feature qw(switch); + +use reader qw(read_str); +use printer qw(_pr_str); + +# read +sub READ { + my $str = shift; + return read_str($str); +} + +# eval +sub EVAL { + my($ast, $env) = @_; + return $ast; +} + +# print +sub PRINT { + my $exp = shift; + return _pr_str($exp); +} + +# repl +sub REP { + my $str = shift; + return PRINT(EVAL(READ($str), {})); +} + +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 new file mode 100644 index 0000000..500a1d3 --- /dev/null +++ b/perl/types.pm @@ -0,0 +1,55 @@ +package types; +use strict; +use warnings; +use Exporter 'import'; +our @EXPORT_OK = qw( $nil $true $false); + +{ + package Nil; + #sub new { my $class = shift; bless {type=>'nil'} => $class } + sub new { my $class = shift; my $s = 'nil'; bless \$s => $class } +} +{ + package True; + sub new { my $class = shift; my $s = 'true'; bless \$s => $class } +} +{ + package False; + sub new { my $class = shift; my $s = 'false'; bless \$s => $class } +} + +our $nil = Nil->new(); +our $true = True->new(); +our $false = False->new(); + +{ + package Integer; + sub new { my $class = shift; bless \$_[0] => $class } +} + +{ + package Symbol; + sub new { my $class = shift; bless \$_[0] => $class } +} + +{ + package String; + sub new { my $class = shift; bless \$_[0] => $class } +} + +{ + package List; + sub new { my $class = shift; bless $_[0], $class } +} + +{ + package Vector; + sub new { my $class = shift; bless $_[0], $class } +} + +{ + package HashMap; + sub new { my $class = shift; bless $_[0], $class } +} + +1; |