Initial revision.

lib/Minilisp.pm

@@ -0,0 +1,321 @@
+package Minilisp;
+
+use strict;
+use warnings;
+use Data::Dumper;
+
+use constant {
+  LPAREN => 1,
+  RPAREN => 2,
+  IDENT => 3,
+  STRING => 4,
+  NUMBER => 5,
+};
+
+sub tokenize {
+  my $str = shift;
+  my @tokens;
+
+  $str =~ s/^\s+//;
+  $str =~ s/\s+$//;
+
+  while ($str)
+    {
+      if ($str =~ s/^\(//)
+        {
+          push @tokens, { type => LPAREN };
+        }
+      elsif($str =~ s/^\)//)
+        {
+          push @tokens, { type => RPAREN };
+        }
+      elsif($str =~ s/^"(([^"\\]|\\.)+)"//)
+        {
+          my $value = $1;
+
+          my %special_chars = (
+            '"' => '"',
+            "n" => "\n",
+            "t" => "\t",
+            "\\" => "\\",
+          );
+
+          $value =~ s/\\(.)/$special_chars{$1}/eg;
+
+          push @tokens, {
+            type => STRING,
+            value => $value,
+          };
+        }
+      elsif($str =~ s/^([^\s()"]+)//)
+        {
+          my $ident = $1;
+          if($ident =~ /^[0-9]+$/)
+            {
+              push @tokens, {
+                type => NUMBER,
+                value => 0+ $ident,
+              };
+            }
+          else
+            {
+              push @tokens, {
+                type => IDENT,
+                value => $ident,
+              };
+            }
+        }
+      else
+        {
+          die "Unknown token: $str";
+        }
+
+      $str =~ s/^\s+//;
+      $str =~ s/\s+$//;
+    }
+  return @tokens;
+}
+
+my %stdctx = (
+  'add' => sub {
+    my $sum = 0;
+    $sum += $_ foreach (@_);
+    return $sum;
+  },
+  'sub' => sub {
+    my $sum = shift;
+    $sum -= $_ foreach (@_);
+    return $sum;
+  },
+  'print' => sub {
+    my $e = shift;
+    print "$e\n";
+    return undef;
+  },
+  'eq' => sub { my ($a, $b) = @_; return ($a eq $b); },
+  'ne' => sub { my ($a, $b) = @_; return ($a ne $b); },
+  '==' => sub { my ($a, $b) = @_; return ($a == $b); },
+  '!=' => sub { my ($a, $b) = @_; return ($a != $b); },
+  '>' => sub { my ($a,$b) = @_; return ($a > $b); },
+  '<' => sub { my ($a,$b) = @_; return ($a < $b); },
+  '>=' => sub { my ($a,$b) = @_; return ($a >= $b); },
+  '<=' => sub { my ($a,$b) = @_; return ($a <= $b); },
+  'not' => sub { my ($a) = @_; return !$a; },
+  't' => 1,
+  'f' => 0,
+  'nil' => undef,
+);
+
+sub parser {
+  my @tokens = @_;
+  my $expr = parser_expr(\@tokens);
+
+  return sub {
+    my $ctx = shift;
+    my $ictx = { %stdctx, %$ctx };
+
+    return $expr->($ictx);
+  }
+}
+
+sub parser_expr {
+  my $ts = shift;
+  my $tok = shift @$ts;
+  if ($tok->{type} == LPAREN)
+    {
+      return parser_call($ts);
+    }
+  elsif($tok->{type} == IDENT)
+    {
+      return sub {
+        my $ctx = shift;
+        my $name = $tok->{value};
+        die "Undefined idnetifier $name" unless
+          exists $ctx->{$name};
+        return $ctx->{$name};
+      }
+    }
+  elsif($tok->{type} == STRING || $tok->{type} == NUMBER)
+    {
+      return sub {
+        return $tok->{value};
+      }
+    }
+  else
+    {
+      die "Unexpected token $tok->{type}\n";
+    }
+}
+
+my %macros;
+
+sub parser_call {
+  my $ts = shift;
+
+  if ($ts->[0]->{type} == IDENT)
+    {
+      my $name = $ts->[0]->{value};
+      if (defined $macros{$name})
+        {
+          shift @$ts;
+          return $macros{$name}->($ts);
+        }
+    }
+
+  my $fn = parser_expr($ts);
+
+  my @params;
+
+  while ($ts->[0]->{type} != RPAREN)
+    {
+      push @params, parser_expr($ts);
+    }
+
+  my $tok = shift @$ts;
+
+  die "Missing )" unless $tok->{type} == RPAREN;
+
+  return sub {
+    my $ctx = shift;
+    my @p = map { $_->($ctx) } @params;
+    $fn->($ctx)->(@p);
+  };
+}
+
+sub macro_let {
+  my $ts = shift;
+
+  my $tok = shift @$ts;
+  die "Expected ( after let" unless $tok->{type} == LPAREN;
+
+  my $pctx = {};
+
+  while ($ts->[0]->{type} != RPAREN)
+    {
+      my $ident = shift @$ts;
+      die "Expected identifier in let" unless $ident->{type} == IDENT;
+
+      my $assignment = parser_expr($ts);
+
+      $pctx->{$ident->{value}} = $assignment;
+    }
+
+  $tok = shift @$ts;
+  die "Expected ) after assignments in let" unless $tok->{type} == RPAREN;
+
+  my $inner = parser_expr($ts);
+
+  $tok = shift @$ts;
+  die "Expected ) after let" unless $tok->{type} == RPAREN;
+
+  return sub {
+    my $octx = shift;
+    my $ictx = { %$octx };
+    $ictx->{$_} = $pctx->{$_}->($octx) foreach (keys %$pctx);
+
+    return $inner->($ictx);
+  }
+}
+$macros{let} = \&macro_let;
+
+sub macro_lambda {
+  my $ts = shift;
+
+  my $tok = shift @$ts;
+  die "Expected ( after lambda keyword" unless $tok->{type} = LPAREN;
+
+  my @param_list;
+  while ($ts->[0]->{type} != RPAREN)
+    {
+      $tok = shift @$ts;
+      die "Expected only identifier in parameter list" unless $tok->{type} == IDENT;
+      push @param_list, $tok->{value};
+    }
+
+  $tok = shift @$ts;
+  die "Expected ) after parameter list in lambda" unless $tok->{type} = LPAREN;
+
+  my $body = parser_expr($ts);
+
+  $tok = shift @$ts;
+  die "Expected ) after lambda" unless $tok->{type} == RPAREN;
+
+  return sub {
+    my $octx = shift;
+    return sub {
+      my $ictx = { %$octx };
+      my @pnames = @param_list;
+      my @pvals = @_;
+      while ( (my $name = shift @pnames) && (my $val = shift @pvals) )
+        {
+          $ictx->{$name} = $val;
+        }
+
+      die "Too many arguments" if scalar(@pvals);
+      die "Not enough arguments" if scalar(@pnames);
+
+      return $body->($ictx);
+    }
+  }
+}
+$macros{lambda} = \&macro_lambda;
+
+sub macro_if {
+  my $ts = shift;
+
+  print Dumper($ts);
+
+  my $cond = parser_expr($ts);
+
+  my $tbranch = parser_expr($ts);
+
+  my $fbranch = parser_expr($ts);
+
+  my $tok = shift @$ts;
+
+  die "Expected ) after else expression" unless $tok->{type} == RPAREN;
+
+  return sub {
+    my $ctx = shift;
+
+    my $condresult = $cond->($ctx);
+    if ($condresult) {
+      return $tbranch->($ctx);
+    } else {
+      return $fbranch->($ctx);
+    }
+  }
+}
+$macros{if} = \&macro_if;
+
+sub macro_progn {
+  my $ts = shift;
+
+  my @steps;
+
+  while ($ts->[0]->{type} != RPAREN)
+    {
+      push @steps, parser_expr($ts);
+    }
+
+  return sub {
+    my $ctx = shift;
+
+    my $result = undef;
+
+    $result = $_->($ctx) foreach (@steps);
+
+    return $result;
+  }
+}
+$macros{progn} = \&macro_progn;
+
+sub compile {
+  my ($term) = @_;
+  my @tokens = tokenize($term);
+  my $parsed = parser(@tokens);
+
+  return $parsed;
+}
+
+1;

test.pl

@@ -0,0 +1,21 @@
+use lib "./lib";
+
+use Minilisp;
+use Data::Dumper;
+
+my $term = <<EOF;
+(progn
+  (print "Hello")
+  (print "World")
+  (print a)
+  1)
+EOF
+
+my $parsed = Minilisp::compile($term);
+
+my $ctx = {
+  'a' => "bar",
+};
+
+print "$term\n";
+print ":= " . $parsed->($ctx) . "\n";