2021-04-01 22:44:06 +02:00
|
|
|
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)
|
|
|
|
{
|
2021-04-02 16:05:22 +02:00
|
|
|
if ($str =~ s/^;.*\n//)
|
|
|
|
{
|
|
|
|
# Comment. do nothing
|
|
|
|
}
|
|
|
|
elsif ($str =~ s/^\(//)
|
2021-04-01 22:44:06 +02:00
|
|
|
{
|
|
|
|
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 = (
|
2021-04-02 01:02:19 +02:00
|
|
|
'+' => sub {
|
2021-04-01 22:44:06 +02:00
|
|
|
my $sum = 0;
|
|
|
|
$sum += $_ foreach (@_);
|
|
|
|
return $sum;
|
|
|
|
},
|
2021-04-02 01:02:19 +02:00
|
|
|
'-' => sub {
|
2021-04-01 22:44:06 +02:00
|
|
|
my $sum = shift;
|
|
|
|
$sum -= $_ foreach (@_);
|
|
|
|
return $sum;
|
|
|
|
},
|
2021-04-02 01:02:19 +02:00
|
|
|
'*' => sub {
|
|
|
|
my $prod = 1;
|
|
|
|
$prod *= $_ foreach(@_);
|
|
|
|
return $prod;
|
|
|
|
},
|
|
|
|
'/' => sub {
|
|
|
|
my $quot = shift;
|
|
|
|
$quot /= $_ foreach(@_);
|
|
|
|
return $quot;
|
|
|
|
},
|
|
|
|
'write-line' => sub {
|
2021-04-01 22:44:06 +02:00
|
|
|
my $e = shift;
|
|
|
|
print "$e\n";
|
|
|
|
return undef;
|
|
|
|
},
|
2021-04-02 01:12:22 +02:00
|
|
|
'null' => sub { my ($a) = @_; return ! defined $a; },
|
|
|
|
'evenp' => sub { my ($a) = @_; return ($a % 2 == 0); },
|
|
|
|
'oddp' => sub { my ($a) = @_; return ($a % 2 != 0); },
|
2021-04-02 03:36:26 +02:00
|
|
|
'zerop' => sub { my ($a) = @_; return $a == 0; },
|
2021-04-02 03:10:24 +02:00
|
|
|
'eq' => sub { my ($a, $b) = @_; return ($a == $b); },
|
|
|
|
'ne' => sub { my ($a, $b) = @_; return ($a != $b); },
|
2021-04-02 03:35:59 +02:00
|
|
|
|
|
|
|
# Logical operators
|
2021-04-02 03:10:24 +02:00
|
|
|
'not' => sub { my ($a) = @_; return !$a; },
|
2021-04-02 03:35:59 +02:00
|
|
|
'and' => sub {
|
|
|
|
my $v = 1;
|
|
|
|
$v &&= $_ foreach (@_);
|
|
|
|
return $v;
|
|
|
|
},
|
|
|
|
'or' => sub {
|
|
|
|
my $v = 0;
|
|
|
|
$v ||= $_ foreach(@_);
|
|
|
|
return $v;
|
|
|
|
},
|
2021-04-02 03:10:24 +02:00
|
|
|
|
|
|
|
# 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); },
|
2021-04-02 03:36:26 +02:00
|
|
|
'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;
|
|
|
|
},
|
2021-04-02 03:10:24 +02:00
|
|
|
|
|
|
|
# String comparison
|
2021-04-02 03:08:19 +02:00
|
|
|
'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)); },
|
2021-04-02 03:10:24 +02:00
|
|
|
|
2021-04-02 03:36:39 +02:00
|
|
|
# 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;
|
|
|
|
},
|
|
|
|
|
2021-04-02 03:10:24 +02:00
|
|
|
# Constants
|
2021-04-01 22:44:06 +02:00
|
|
|
't' => 1,
|
|
|
|
'f' => 0,
|
|
|
|
'nil' => undef,
|
|
|
|
);
|
|
|
|
|
|
|
|
sub parser {
|
|
|
|
my @tokens = @_;
|
2021-04-02 02:45:49 +02:00
|
|
|
my $expr = parser_prog(\@tokens);
|
2021-04-01 22:44:06 +02:00
|
|
|
|
|
|
|
return sub {
|
|
|
|
my $ctx = shift;
|
|
|
|
my $ictx = { %stdctx, %$ctx };
|
|
|
|
|
|
|
|
return $expr->($ictx);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2021-04-02 02:45:49 +02:00
|
|
|
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;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2021-04-01 22:44:06 +02:00
|
|
|
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)
|
|
|
|
{
|
2021-04-02 01:02:35 +02:00
|
|
|
$tok = shift @$ts;
|
|
|
|
die "Expected pair in parameter list in let" unless $tok->{type} == LPAREN;
|
|
|
|
|
2021-04-01 22:44:06 +02:00
|
|
|
my $ident = shift @$ts;
|
2021-04-02 01:02:35 +02:00
|
|
|
die "Expected identifier in pair in parameter list in let" unless $ident->{type} == IDENT;
|
2021-04-01 22:44:06 +02:00
|
|
|
|
2021-04-02 01:02:35 +02:00
|
|
|
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;
|
2021-04-01 22:44:06 +02:00
|
|
|
|
|
|
|
$pctx->{$ident->{value}} = $assignment;
|
|
|
|
}
|
|
|
|
|
|
|
|
$tok = shift @$ts;
|
2021-04-02 01:02:35 +02:00
|
|
|
die "Expected ) after parameter list in let" unless $tok->{type} == RPAREN;
|
2021-04-01 22:44:06 +02:00
|
|
|
|
2021-04-02 01:02:35 +02:00
|
|
|
my $inner = macro_progn($ts);
|
2021-04-01 22:44:06 +02:00
|
|
|
|
|
|
|
return sub {
|
|
|
|
my $octx = shift;
|
|
|
|
my $ictx = { %$octx };
|
|
|
|
$ictx->{$_} = $pctx->{$_}->($octx) foreach (keys %$pctx);
|
|
|
|
|
|
|
|
return $inner->($ictx);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
$macros{let} = \¯o_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} = \¯o_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} = \¯o_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} = \¯o_progn;
|
|
|
|
|
2021-04-02 01:07:17 +02:00
|
|
|
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;
|
2021-04-02 02:46:14 +02:00
|
|
|
my $fn;
|
|
|
|
my $self = sub {
|
|
|
|
return $fn->(@_);
|
|
|
|
};
|
|
|
|
$ctx->{$ident->{value}} = $self;
|
|
|
|
$fn = $body->($ctx);
|
2021-04-02 01:07:17 +02:00
|
|
|
$ctx->{$ident->{value}} = $fn;
|
|
|
|
return $fn;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
$macros{defun} = \¯o_defun;
|
|
|
|
|
2021-04-01 22:44:06 +02:00
|
|
|
sub compile {
|
|
|
|
my ($term) = @_;
|
|
|
|
my @tokens = tokenize($term);
|
|
|
|
my $parsed = parser(@tokens);
|
|
|
|
|
|
|
|
return $parsed;
|
|
|
|
}
|
|
|
|
|
|
|
|
1;
|