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,
  KEYWORD => 6,
  LIST => 7,
};

use constant {
  LISP_TRUE => 1,
  LISP_FALSE => undef,
};

sub to_lisp_bool {
  return shift ? LISP_TRUE : LISP_FALSE;
}

sub from_lisp_bool {
  return defined(shift);
}

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/^'\(//) # short notation for lists
        {
          push @tokens, { type => LIST }, { type => LPAREN };
        }
      elsif($str =~ s/^'([^\s()"]+)//)
        {
          push @tokens, {
            type => KEYWORD,
            value => $1,
          };
        }
      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 eq ".")
            {
              die "short cons not supported"
            }
          elsif($ident =~ /^-?([0-9]+|[0-9]*\.[0-9]*)$/)
            {
              if($ident =~ s/^-//)
                {
                  $ident = 0 - $ident;
                }

              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;
}

sub ctx_create {
  my $base = shift || undef;
  my $vars = shift || {};

  return {
    base => $base,
    vars => $vars
  };
}

sub ctx_get {
  my $ctx = shift;
  my $identifier = shift;

  while (defined $ctx && !exists($ctx->{vars}->{$identifier}))
    {
      $ctx = $ctx->{base};
    }

  die "Identifier $identifier is not defined" unless defined $ctx;

  return $ctx->{vars}->{$identifier};
}

sub ctx_set {
  my $ctx = shift;
  my $identifier = shift;
  my $value = shift;

  $ctx->{vars}->{$identifier} = $value;
}

sub ctx_assign {
  my $ctx = shift;
  my $identifier = shift;
  my $value = shift;

  while (defined $ctx && !exists($ctx->{vars}->{$identifier}))
    {
      $ctx = $ctx->{base};
    }

  die "Variable $identifier is not defined" unless defined $ctx;

  $ctx->{vars}->{$identifier} = $value;
}

sub lisp_format {
  my $e = shift;
  if (ref($e) eq "ARRAY")
    {
      return "(" . join(" ", map { lisp_format($_) } @$e) . ")";
    }
  elsif (ref($e) eq "KEYWORD")
    {
      return "'" . $e->{value};
    }
  else
    {
      return "$e";
    }
}

sub lisp_equal {
  my ($a, $b) = @_;
  if ( ref($a) eq "ARRAY" && ref($b) eq "ARRAY" )
    {
      return LISP_FALSE unless scalar(@$a) == scalar(@$b);

      for(my $i = 0; $i < @$a; $i++)
        {
          return LISP_FALSE unless lisp_equal($a->[$i], $b->[$i]);
        }

      return LISP_TRUE;
    }
  elsif ( ref($a) eq "KEYWORD" && ref($b) eq "KEYWORD" )
    {
      return to_lisp_bool($a->{value} eq $b->{value});
    }
  elsif ( ref($a) eq "" && ref($b) eq "" )
    {
      return to_lisp_bool($a == $b);
    }
  else
    {
      return LISP_FALSE;
    }
}

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 lisp_format($e) . "\n";
    return undef;
  },
  'write' => sub {
    my $e = shift;
    print lisp_format($e);
    return undef;
  },
  'null' => sub { my ($a) = @_; return ! defined $a; },
  'evenp' => sub { my ($a) = @_; return to_lisp_bool($a % 2 == 0); },
  'oddp' => sub { my ($a) = @_; return to_lisp_bool($a % 2 != 0); },
  'zerop' => sub { my ($a) = @_; return to_lisp_bool($a == 0); },
  'eq' => sub { my ($a, $b) = @_; return to_lisp_bool($a == $b); },
  'ne' => sub { my ($a, $b) = @_; return to_lisp_bool($a != $b); },

  # Logical operators
  'not' => sub { my ($a) = @_; return to_lisp_bool(!from_lisp_bool($a)); },

  # Numeric comparison
  '=' => sub { my ($a, $b) = @_; return to_lisp_bool($a == $b); },
  '/=' => sub { my ($a, $b) = @_; return to_lisp_bool($a != $b); },
  '>' => sub { my ($a,$b) = @_; return to_lisp_bool($a > $b); },
  '<' => sub { my ($a,$b) = @_; return to_lisp_bool($a < $b); },
  '>=' => sub { my ($a,$b) = @_; return to_lisp_bool($a >= $b); },
  '<=' => sub { my ($a,$b) = @_; return to_lisp_bool($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;
  },
  'mod' => sub {
    my ($number, $divisor) = @_;
    $number += $divisor while ( $number < 0 );
    $number -= $divisor while ( $number >= $divisor );

    return $number;
  },

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

  # string operations
  'string-upcase' => sub { return uc(shift); },
  'string-downcase' => sub { return lc(shift); },
  'string-capitalize' => sub {
    my $str = shift;
    return $str =~ s/(\S+)/ucfirst($1)/erg;
  },

  # 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;
  },

  # Lists
  'list' => sub { return [ @_ ]; },
  'first' => sub { return (shift)->[0]; },
  'second' => sub { return (shift)->[1]; },
  'nth' => sub { my ($idx,$list) = @_; return $list->[$idx]; },
  'map' => sub {
    my ($cb,$list) = @_;
    die "map: First parameter must be a function" unless ref($cb) eq "CODE";
    die "map: Second parameter must be a list" unless ref($list) eq "ARRAY";

    return [ map { $cb->($_) } @$list ];
  },
  'reduce' => sub {
    my ($cb,$list) = @_;
    die "map: First parameter must be a function" unless ref($cb) eq "CODE";
    die "map: Second parameter must be a list" unless ref($list) eq "ARRAY";

    my @copy = ( @$list );
    my $v = shift @copy;
    $v = $cb->($v,$_) foreach (@copy);
    return $v;
  },
  'filter' => sub {
    my ($cb, $list) = @_;
    die "map: First parameter must be a function" unless ref($cb) eq "CODE";
    die "map: Second parameter must be a list" unless ref($list) eq "ARRAY";

    return [ grep { $cb->($_) } @$list ];
  },
  'cons' => sub {
    my ($v, $list) = @_;
    return [ $v, @$list ];
  },
  'car' => sub {
    my ($list) = @_;
    return $list->[0];
  },
  'cdr' => sub {
    my ($list) = @_;
    my @newlist = @$list;
    shift @newlist; # drop first element
    return \@newlist;
  },

  # Constants
  't' => LISP_TRUE,
  'nil' => LISP_FALSE,

  # Multi-purpose
  'equal' => \&lisp_equal,
  'length' => sub {
    my ($a) = @_;

    if (ref($a) eq "ARRAY")
      {
        return scalar(@$a);
      }
    else
      {
        return length($a);
      }
  },
);

sub parser {
  my @tokens = @_;
  my $expr = parser_prog(\@tokens);
  my $base_ctx = ctx_create(undef, \%stdctx);

  return sub {
    my $vars = shift;
    my $ctx = ctx_create($base_ctx, $vars);

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

sub parser_many_expr {
  my $ts = shift;
  my @exprs;

  while (scalar(@$ts) && !peek_token($ts,RPAREN))
    {
      push @exprs, parser_expr($ts);
    }

  return @exprs;
}

sub parser_prog {
  my $ts = shift;

  my @steps = parser_many_expr($ts);

  die "Unexpected token " . $ts->[0]->{type} . " after end of program"
    if scalar(@$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} == LIST)
    {
      return parser_list($ts);
    }
  elsif($tok->{type} == IDENT)
    {
      return sub {
        my $ctx = shift;
        my $name = $tok->{value};
        return ctx_get($ctx, $name);
      }
    }
  elsif($tok->{type} == KEYWORD)
    {
      my $k = bless { value => $tok->{value} }, "KEYWORD";
      return sub { return $k; };
    }
  elsif($tok->{type} == STRING || $tok->{type} == NUMBER)
    {
      return sub {
        return $tok->{value};
      }
    }
  else
    {
      die "Unexpected token $tok->{type}\n";
    }
}

sub slurp_token {
  my $ts = shift;
  my $expected_type = shift;
  my $msg = shift || "Expected $expected_type";
  my $tok = shift @$ts;

  die "$msg" unless $tok->{type} == $expected_type;

  return $tok;
}

sub peek_token {
  my ($ts, $type) = @_;
  return $ts->[0]->{type} == $type;
}

sub parser_list {
  my $ts = shift;

  slurp_token($ts, LPAREN, "Expected ( after ' for list");

  my @elements = parser_many_expr($ts);

  slurp_token($ts, RPAREN, "Expected ) after list");

  return sub {
    my $ctx = shift;

    return [ map { $_->($ctx) } @elements ];
  }
}

my %macros;

sub parser_call {
  my $ts = shift;

  if (peek_token($ts,IDENT))
    {
      my $name = $ts->[0]->{value};
      if (defined $macros{$name})
        {
          shift @$ts;
          my $parsed = $macros{$name}->($ts);
          slurp_token($ts, RPAREN, "Expected ) after macro $name");
          return $parsed;
        }
    }

  my $fn = parser_expr($ts);

  my @params = parser_many_expr($ts);

  slurp_token($ts, RPAREN, "Expecte ) after call");

  return sub {
    my $ctx = shift;
    my @p = map { $_->($ctx) } @params;
    $fn->($ctx)->(@p);
  };
}

sub create_block {
  my $blockname = shift;
  my $inner = shift;

  return sub {
    my $ctx = shift;

    my $result;
    eval {
      $result = $inner->($ctx);
    };

    if ($@)
      {
        if (ref($@) eq "BLOCK::$blockname")
          {
            return $@->{retval};
          }
        else
          {
            die $@;
          }
      }

    return $result;
  };
}

sub return_from_block {
  my $blockname = shift;
  my $retval = shift;

  die bless({ retval => $retval }, "BLOCK::$blockname");
}

sub gen_macro_let {
  my $incremental = shift;
  return sub {
    my $ts = shift;

    slurp_token($ts, LPAREN, "Expected ( after let");

    my @assignments;

    while (!peek_token($ts,RPAREN))
      {
        slurp_token($ts, LPAREN, "Expected ( before assignment in let");

        my $ident = slurp_token($ts, IDENT)->{value};

        my $expr;
        if (peek_token($ts,RPAREN))
          {
            $expr = sub { return undef };
          }
        else
          {
            $expr = parser_expr($ts)
          }

        slurp_token($ts, RPAREN, "Expected ) after assignment in let");

        push @assignments, {
          ident => $ident,
          expr => $expr
        };
      }

    slurp_token($ts, RPAREN);

    my $inner = macro_progn($ts);

    return sub {
      my $octx = shift;
      my $ictx = ctx_create($octx);
      ctx_set($ictx, $_->{ident}, $_->{expr}->($incremental ? $ictx : $octx)) foreach (@assignments);

      return $inner->($ictx);
    };
  };
}
$macros{let} = gen_macro_let(0);
$macros{'let*'} = gen_macro_let(1);

sub macro_lambda {
  my $ts = shift;

  slurp_token($ts, LPAREN, "Expected ( after lambda keyword");

  my @param_list;
  while (!peek_token($ts,RPAREN))
    {
      my $ident = slurp_token($ts, IDENT)->{value};
      push @param_list, $ident;
    }

  slurp_token($ts, RPAREN, "Expected ) after parameter list in lambda");

  my $body = parser_expr($ts);

  return sub {
    my $octx = shift;
    return sub {
      my $ictx = ctx_create($octx);
      my @pnames = @param_list;
      my @pvals = @_;

      while ( @pnames && @pvals )
        {
          my $name = shift @pnames;
          my $val = shift @pvals;
          ctx_set($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);

  return sub {
    my $ctx = shift;

    my $condresult = $cond->($ctx);
    if (defined $condresult) {
      return $tbranch->($ctx);
    } else {
      return $fbranch->($ctx);
    }
  }
}
$macros{if} = \&macro_if;

sub macro_progn {
  my $ts = shift;

  my @steps = parser_many_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 = slurp_token($ts, IDENT)->{value};

  my $body = macro_lambda($ts);

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

sub macro_cond {
  my $ts = shift;

  my @cases;
  while (!peek_token($ts,RPAREN))
    {
      slurp_token($ts, LPAREN, "Expected ( before case in cond");

      my $condition = parser_expr($ts);
      my $work = parser_expr($ts);

      slurp_token($ts, RPAREN, "Expected ) after case in cond");

      push @cases, {
        condition => $condition,
        work => $work,
      };
    }

  return sub {
    my $ctx = shift;

    foreach my $case (@cases)
      {
        if($case->{condition}->($ctx))
          {
            return $case->{work}->($ctx);
          }
      }

    return undef;
  }
}
$macros{cond} = \&macro_cond;

sub macro_when {
  my $ts = shift;

  my $condition = parser_expr($ts);
  my $work = macro_progn($ts);

  return sub {
    my $ctx = shift;

    if (defined($condition->($ctx)))
      {
        return $work->($ctx);
      }

    return undef;
  }
}
$macros{when} = \&macro_when;

sub macro_unless {
  my $ts = shift;

  my $condition = parser_expr($ts);
  my $work = macro_progn($ts);

  return sub {
    my $ctx = shift;

    if (!defined($condition->($ctx)))
      {
        return $work->($ctx);
      }

    return undef;
  }
}
$macros{unless} = \&macro_unless;

sub macro_set {
  my $ts = shift;

  my $ident = slurp_token($ts, IDENT, "Expected identifier after set")->{value};

  my $expr = parser_expr($ts);

  return sub {
    my $ctx = shift;

    my $value = $expr->($ctx);

    ctx_assign($ctx, $ident, $value);

    return $value;
  }
}
$macros{set} = \&macro_set;

sub macro_and {
  my $ts = shift;

  my @operands_parsed = parser_many_expr($ts);

  return sub {
    my $ctx = shift;

    my $v = LISP_TRUE;
    my @operands = @operands_parsed;
    while (from_lisp_bool($v) && (my $op = shift @operands))
      {
        $v = $op->($ctx);
      }

    return $v;
  };
}
$macros{and} = \&macro_and;

sub macro_or {
  my $ts = shift;

  my @operands_parsed = parser_many_expr($ts);

  return sub {
    my $ctx = shift;

    my $v = LISP_FALSE;
    my @operands = @operands_parsed;
    while (!from_lisp_bool($v) && (my $op = shift @operands))
      {
        $v = $op->($ctx);
      }

    return $v;
  };
}
$macros{or} = \&macro_or;

sub macro_do {
  my $ts = shift;

  slurp_token($ts, LPAREN, "Expected ( after do");

  my @vars;

  while(!peek_token($ts, RPAREN))
    {
      my $name = undef;
      my $init = undef;
      my $step = undef;

      if (peek_token($ts, IDENT))
        {
          $name = slurp_token($ts,IDENT)->{value};
        }
      else
        {
          slurp_token($ts, LPAREN, "Expected either identifier or ( in var list");

          $name = slurp_token($ts, IDENT)->{value};

          if ( !peek_token($ts, RPAREN) )
            {
              $init = parser_expr($ts);

              if ( !peek_token($ts, RPAREN) )
                {
                  $step = parser_expr($ts);
                }
            }

          slurp_token($ts, RPAREN, "Expected ) after var");
        }

      push @vars, {
        name => $name,
        init => $init,
        step => $step,
      };
    }

  slurp_token($ts, RPAREN, "Expected ) after var list");

  slurp_token($ts, LPAREN, "Expected ( before end-test-form");

  my $end_test_form = parser_expr($ts);

  my $result_form = macro_progn($ts);

  slurp_token($ts, RPAREN, "Expected ) after resultform");

  my $body = macro_progn($ts);

  return sub {
    my $octx = shift;
    my $ictx = ctx_create($octx);

    foreach my $var (@vars)
      {
        my $val = undef;
        $val = $var->{init}->($octx) if defined $var->{init};
        ctx_set($ictx, $var->{name}, $val);
      }

    while ( !from_lisp_bool($end_test_form->($ictx)) )
      {
        $body->($ictx);

        my %steps;
        foreach my $var (@vars)
          {
            next unless defined $var->{step};
            $steps{$var->{name}} = $var->{step}->($ictx);
          }

        ctx_set($ictx, $_, $steps{$_}) foreach (keys %steps);
      }

    return $result_form->($ictx);
  }
}
$macros{do} = \&macro_do;

sub macro_block {
  my $ts = shift;

  my $blockname = slurp_token($ts, IDENT, "Expected identifier after block")->{value};

  my $inner = macro_progn($ts);

  return create_block($blockname, $inner);
}
$macros{block} = \&macro_block;


sub macro_return_common {
  my $ts = shift;
  my $blockname = shift;

  my $return_expr = sub { undef };

  $return_expr = parser_expr($ts) unless peek_token($ts, RPAREN);

  return sub {
    my $ctx = shift;

    my $retval = $return_expr->($ctx);

    return_from_block($blockname, $retval);
  }
}

sub macro_return_from {
  my $ts = shift;

  my $blockname = slurp_token($ts, IDENT, "Expected identifier after block")->{value};

  return macro_return_common($ts, $blockname);
}
$macros{'return-from'} = \&macro_return_from;

sub macro_return {
  my $ts = shift;
  return macro_return_common($ts, "nil");
}
$macros{'return'} = \&macro_return;

sub macro_loop {
  my $ts = shift;

  my $inner = macro_progn($ts);

  return create_block(
    "nil",
    sub {
      my $ctx = shift;

      while (1)
        {
          $inner->($ctx);
        }
    }
  );
}
$macros{loop} = \&macro_loop;

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

  return $parsed;
}

sub compile_file {
  my $file = shift;

  open(my $fh, "<", $file) or die "Could not open $file: $!";
  my $script = do { local $/; <$fh> };
  close($fh);

  return compile($script);
}

1;