Minilisp.pm/lib/Minilisp.pm

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/^;.*\n//)
        {
          # Comment. do nothing
        }
      elsif ($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 = (
  '+' => sub {
    my $sum = 0;
    $sum += $_ foreach (@_);
    return $sum;
  },
  '-' => sub {
    my $sum = shift;
    $sum -= $_ foreach (@_);
    return $sum;
  },
  '*' => sub {
    my $prod = 1;
    $prod *= $_ foreach(@_);
    return $prod;
  },
  '/' => sub {
    my $quot = shift;
    $quot /= $_ foreach(@_);
    return $quot;
  },
  'write-line' => sub {
    my $e = shift;
    print "$e\n";
    return undef;
  },
  'null' => sub { my ($a) = @_; return ! defined $a; },
  'evenp' => sub { my ($a) = @_; return ($a % 2 == 0); },
  'oddp' => sub { my ($a) = @_; return ($a % 2 != 0); },
  'zerop' => sub { my ($a) = @_; return $a == 0; },
  'eq' => sub { my ($a, $b) = @_; return ($a == $b); },
  'ne' => sub { my ($a, $b) = @_; return ($a != $b); },

  # Logical operators
  'not' => sub { my ($a) = @_; return !$a; },
  'and' => sub {
    my $v = 1;
    $v &&= $_ foreach (@_);
    return $v;
  },
  'or' => sub {
    my $v = 0;
    $v ||= $_ foreach(@_);
    return $v;
  },

  # Numeric comparison
  '=' => 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); },
  'max' => sub {
    die "max: At least 2 parameters" unless scalar(@_) >= 2;
    my $v = shift;
    foreach (@_)
      {
        $v = $_ if $v < $_;
      }
    return $v;
  },
  'min' => sub {
    die "min: At least 2 parameters" unless scalar(@_) >= 2;
    my $v = shift;
    foreach (@_)
      {
        $v = $_ if $v > $_;
      }
    return $v;
  },

  # String comparison
  'string=' => sub { my ($a, $b) = @_; return ($a eq $b); },
  'string/=' => sub { my ($a, $b) = @_; return ($a ne $b); },
  'string<' => sub { my ($a, $b) = @_; return ($a lt $b); },
  'string>' => sub { my ($a, $b) = @_; return ($a gt $b); },
  'string<=' => sub { my ($a, $b) = @_; return !($a gt $b); },
  'string>=' => sub { my ($a, $b) = @_; return !($a lt $b); },
  'string-equal' => sub { my ($a, $b) = @_; return ( lc($a) eq lc($b)); },
  'string-not-equal' => sub { my ($a, $b) = @_; return (lc($a) ne lc($b)); },
  'string-lessp' => sub { my ($a, $b) = @_; return (lc($a) lt lc($b)); },
  'string-greaterp' => sub { my ($a, $b) = @_; return (lc($a) gt lc($b)); },
  'string-not-greaterp' => sub { my ($a, $b) = @_; return !(lc($a) gt lc($b)); },
  'string-not-lessp' => sub { my ($a, $b) = @_; return !(lc($a) lt lc($b)); },

  # Bitwise operations
  'logand' => sub {
    my $v = -1;
    $v &= $_ foreach (@_);
    return $v;
  },
  'logior' => sub {
    my $v = 0;
    $v |= $_ foreach (@_);
    return $v;
  },
  'logxor' => sub {
    my $v = 0;
    $v ^= $_ foreach (@_);
    return $v;
  },
  'lognor' => sub {
    my $v = -1;
    $v |= $_ foreach (@_);
    return ~$v;
  },
  'logeqv' => sub {
    my $v = 0;
    $v ^= $_ foreach (@_);
    return ~$v;
  },

  # Constants
  't' => 1,
  'f' => 0,
  'nil' => undef,
);

sub parser {
  my @tokens = @_;
  my $expr = parser_prog(\@tokens);

  return sub {
    my $ctx = shift;
    my $ictx = { %stdctx, %$ctx };

    return $expr->($ictx);
  }
}

sub parser_prog {
  my $ts = shift;

  my @steps;

  while (scalar @$ts)
    {
      push @steps, parser_expr($ts);
    }

  return sub {
    my $ctx = shift;
    my $result;
    $result = $_->($ctx) foreach (@steps);
    return $result;
  }
}

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)
    {
      $tok = shift @$ts;
      die "Expected pair in parameter list in let" unless $tok->{type} == LPAREN;

      my $ident = shift @$ts;
      die "Expected identifier in pair in parameter list in let" unless $ident->{type} == IDENT;

      my $assignment;
      if ($ts->[0]->{type} == RPAREN)
        {
          $assignment = sub { return undef };
        }
      else
        {
          $assignment = parser_expr($ts)
        }

      $tok = shift @$ts;
      die "Expected ) after parameter pair" unless $tok->{type} == RPAREN;

      $pctx->{$ident->{value}} = $assignment;
    }

  $tok = shift @$ts;
  die "Expected ) after parameter list in let" unless $tok->{type} == RPAREN;

  my $inner = macro_progn($ts);

  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;

  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 macro_defun {
  my $ts = shift;

  my $ident = shift @$ts;
  die "Expected identifier in defun" unless $ident->{type} == IDENT;

  my $body = macro_lambda($ts);

  return sub {
    my $ctx = shift;
    my $fn;
    my $self = sub {
      return $fn->(@_);
    };
    $ctx->{$ident->{value}} = $self;
    $fn = $body->($ctx);
    $ctx->{$ident->{value}} = $fn;
    return $fn;
  }
}
$macros{defun} = \&macro_defun;

sub compile {
  my ($term) = @_;
  my @tokens = tokenize($term);
  my $parsed = parser(@tokens);

  return $parsed;
}

1;