1287 lines
26 KiB
Perl
1287 lines
26 KiB
Perl
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+$//;
|
|
|
|
my $debug = sub {};
|
|
|
|
$debug = sub {
|
|
my $msg = shift;
|
|
my $strcpy = $str;
|
|
$strcpy =~ s/^/ /mg;
|
|
print "-- $msg\n$strcpy\n";
|
|
} if !!$ENV{LEXER_DEBUG};
|
|
|
|
$debug->("Begin parsing");
|
|
|
|
while ($str)
|
|
{
|
|
if ($str =~ s/^;.*(\n|$)//)
|
|
{
|
|
$debug->("Comment");
|
|
# Comment. do nothing
|
|
}
|
|
elsif ($str =~ s/^\(//)
|
|
{
|
|
$debug->("Left parenthesis");
|
|
push @tokens, { type => LPAREN };
|
|
}
|
|
elsif($str =~ s/^\)//)
|
|
{
|
|
$debug->("Right parenthesis");
|
|
push @tokens, { type => RPAREN };
|
|
}
|
|
elsif($str =~ s/^'\(//) # short notation for lists
|
|
{
|
|
$debug->("Short list");
|
|
push @tokens, { type => LIST }, { type => LPAREN };
|
|
}
|
|
elsif($str =~ s/^'([^\s()"]+)//)
|
|
{
|
|
$debug->("Keyword $1");
|
|
push @tokens, {
|
|
type => KEYWORD,
|
|
value => $1,
|
|
};
|
|
}
|
|
elsif($str =~ s/^"(([^"\\]|\\.)*)"//)
|
|
{
|
|
$debug->("String '$1'");
|
|
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]*)$/)
|
|
{
|
|
$debug->("Number '$1'");
|
|
if($ident =~ s/^-//)
|
|
{
|
|
$ident = 0 - $ident;
|
|
}
|
|
|
|
push @tokens, {
|
|
type => NUMBER,
|
|
value => 0+ $ident,
|
|
};
|
|
}
|
|
else
|
|
{
|
|
$debug->("Identifier '$1'");
|
|
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 ( !defined($a) && !defined($b) )
|
|
{
|
|
return LISP_TRUE;
|
|
}
|
|
elsif ( 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);
|
|
}
|
|
},
|
|
'apply' => sub {
|
|
my ($fn, $lst) = @_;
|
|
die "apply: First operand must be a function"
|
|
unless ref($fn) eq "CODE";
|
|
die "apply: Second operand must be a list"
|
|
unless ref($lst) eq "ARRAY";
|
|
|
|
return $fn->(@$lst);
|
|
},
|
|
|
|
# Input/output
|
|
'read-line' => sub {
|
|
my $fh = shift;
|
|
my $val = defined($fh) ? <$fh> : <>;
|
|
chomp $val;
|
|
return $val;
|
|
}
|
|
);
|
|
|
|
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;
|
|
eval {
|
|
$result = $_->($ctx) foreach (@steps);
|
|
};
|
|
if ($@)
|
|
{
|
|
if(my $type = ref($@))
|
|
{
|
|
if($type =~ /^return::(.*)$/)
|
|
{
|
|
die "return from block $1 outside of any block named $1";
|
|
}
|
|
elsif ($type =~ /^throw::(.*)$/)
|
|
{
|
|
die "Uncaught exception $1";
|
|
}
|
|
elsif ($type eq "goto")
|
|
{
|
|
die "Target $@->{section} of go statement not found";
|
|
}
|
|
}
|
|
die "$@";
|
|
}
|
|
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 "return::$blockname")
|
|
{
|
|
return $@->{retval};
|
|
}
|
|
else
|
|
{
|
|
die $@;
|
|
}
|
|
}
|
|
|
|
return $result;
|
|
};
|
|
}
|
|
|
|
sub return_from_block {
|
|
my $blockname = shift;
|
|
my $retval = shift;
|
|
|
|
die bless({ retval => $retval }, "return::$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} = \¯o_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} = \¯o_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} = \¯o_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} = \¯o_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} = \¯o_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} = \¯o_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} = \¯o_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} = \¯o_set;
|
|
|
|
sub macro_and {
|
|
my $ts = shift;
|
|
|
|
my @operands_parsed = parser_many_expr($ts);
|
|
|
|
return sub {
|
|
my $ctx = shift;
|
|
|
|
return LISP_FALSE unless @operands_parsed;
|
|
|
|
my $v = LISP_TRUE;
|
|
my @operands = @operands_parsed;
|
|
while (from_lisp_bool($v) && (my $op = shift @operands))
|
|
{
|
|
$v = $op->($ctx);
|
|
}
|
|
|
|
return $v;
|
|
};
|
|
}
|
|
$macros{and} = \¯o_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} = \¯o_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_tagbody($ts);
|
|
|
|
return create_block("nil", 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} = \¯o_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} = \¯o_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'} = \¯o_return_from;
|
|
|
|
sub macro_return {
|
|
my $ts = shift;
|
|
return macro_return_common($ts, "nil");
|
|
}
|
|
$macros{'return'} = \¯o_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} = \¯o_loop;
|
|
|
|
sub macro_catch {
|
|
my $ts = shift;
|
|
|
|
my $tag_expr = parser_expr($ts);
|
|
|
|
my $inner = macro_progn($ts);
|
|
|
|
return sub {
|
|
my $ctx = shift;
|
|
|
|
my $tag = $tag_expr->($ctx);
|
|
|
|
die "Expected tag expr after catch to evaluate to keyword"
|
|
unless ref($tag) eq "KEYWORD";
|
|
|
|
my $tagname = $tag->{value};
|
|
|
|
my $result;
|
|
eval {
|
|
$result = $inner->($ctx);
|
|
};
|
|
|
|
if($@) {
|
|
if (ref($@) eq "throw::$tagname")
|
|
{
|
|
return $@->{retval};
|
|
}
|
|
else
|
|
{
|
|
die $@;
|
|
}
|
|
}
|
|
return $result;
|
|
}
|
|
}
|
|
$macros{catch} = \¯o_catch;
|
|
|
|
sub macro_throw {
|
|
my $ts = shift;
|
|
|
|
my $tag_expr = parser_expr($ts);
|
|
|
|
my $inner = parser_expr($ts);
|
|
|
|
return sub {
|
|
my $ctx = shift;
|
|
|
|
my $tag = $tag_expr->($ctx);
|
|
|
|
die "Expected tag expr after throw to evaluate to keyword"
|
|
unless ref($tag) eq "KEYWORD";
|
|
|
|
my $tagname = $tag->{value};
|
|
|
|
my $retval = $inner->($ctx);
|
|
|
|
die bless({ retval => $retval }, "throw::$tagname");
|
|
}
|
|
}
|
|
$macros{throw} = \¯o_throw;
|
|
|
|
sub macro_dotimes {
|
|
my $ts = shift;
|
|
|
|
slurp_token($ts, LPAREN, "Expected ( after dotimes");
|
|
|
|
my $var = slurp_token($ts, IDENT, "Expected identifier for var in dotimes")->{value};
|
|
|
|
my $count_expr = parser_expr($ts);
|
|
|
|
my $result_expr = sub { undef };
|
|
$result_expr = parser_expr($ts) unless peek_token($ts, RPAREN);
|
|
|
|
slurp_token($ts, RPAREN, "Expected ) after count-form or result-form in dotimes");
|
|
|
|
my $body = macro_tagbody($ts);
|
|
|
|
return create_block(
|
|
"nil",
|
|
sub {
|
|
my $octx = shift;
|
|
|
|
my $n = $count_expr->($octx);
|
|
|
|
my $ictx = ctx_create($octx);
|
|
|
|
for(my $i = 0; $i < $n; $i++)
|
|
{
|
|
ctx_set($ictx, $var, $i);
|
|
$body->($ictx);
|
|
}
|
|
|
|
ctx_set($ictx, $var, $n);
|
|
return $result_expr->($ictx);
|
|
}
|
|
);
|
|
}
|
|
$macros{dotimes} = \¯o_dotimes;
|
|
|
|
sub macro_dolist {
|
|
my $ts = shift;
|
|
|
|
slurp_token($ts, LPAREN, "Expected ( after dolist");
|
|
|
|
my $var = slurp_token($ts, IDENT, "Expected identifier for var in dolist")->{value};
|
|
|
|
my $list_expr = parser_expr($ts);
|
|
|
|
my $result_expr = sub { undef };
|
|
$result_expr = parser_expr($ts) unless peek_token($ts, RPAREN);
|
|
|
|
slurp_token($ts, RPAREN, "Expected ) after list-form or result-form in dolist");
|
|
|
|
my $body = macro_tagbody($ts);
|
|
|
|
return create_block(
|
|
"nil",
|
|
sub {
|
|
my $octx = shift;
|
|
|
|
my $lst = $list_expr->($octx);
|
|
|
|
die "Expected list in dolist"
|
|
unless ref($lst) eq "ARRAY";
|
|
|
|
my $ictx = ctx_create($octx);
|
|
|
|
foreach my $e (@$lst)
|
|
{
|
|
ctx_set($ictx, $var, $e);
|
|
$body->($ictx);
|
|
}
|
|
|
|
ctx_set($ictx, $var, undef);
|
|
return $result_expr->($ictx);
|
|
}
|
|
);
|
|
}
|
|
$macros{dolist} = \¯o_dolist;
|
|
|
|
sub macro_tagbody {
|
|
my $ts = shift;
|
|
|
|
my $init_symbol = bless({},"init");
|
|
|
|
my $parse_section = $init_symbol;
|
|
my %schedule;
|
|
my %sections;
|
|
$sections{$parse_section} = [];
|
|
while (!peek_token($ts, RPAREN))
|
|
{
|
|
if (peek_token($ts, IDENT))
|
|
{
|
|
my $next_parse_section = slurp_token($ts, IDENT)->{value};
|
|
$schedule{$parse_section} = $next_parse_section;
|
|
$parse_section = $next_parse_section;
|
|
$sections{$parse_section} = [];
|
|
}
|
|
else
|
|
{
|
|
push @{$sections{$parse_section}}, parser_expr($ts);
|
|
}
|
|
}
|
|
|
|
return sub {
|
|
my $octx = shift;
|
|
my $ictx = ctx_create($octx);
|
|
|
|
my $current_section = $init_symbol;
|
|
|
|
do {
|
|
eval {
|
|
$_->($ictx) foreach @{$sections{$current_section}};
|
|
1;
|
|
};
|
|
if ($@)
|
|
{
|
|
if (ref($@) eq "goto" && exists($sections{$@->{section}}))
|
|
{
|
|
$current_section = $@->{section}
|
|
}
|
|
else
|
|
{
|
|
die $@;
|
|
}
|
|
}
|
|
else
|
|
{
|
|
$current_section = $schedule{$current_section};
|
|
}
|
|
} while($current_section);
|
|
};
|
|
}
|
|
$macros{tagbody} = \¯o_tagbody;
|
|
|
|
sub macro_go {
|
|
my $ts = shift;
|
|
|
|
my $ident = slurp_token($ts, IDENT, "Expected identifier after go")->{value};
|
|
|
|
return sub {
|
|
die bless({ section => $ident }, "goto");
|
|
};
|
|
}
|
|
$macros{go} = \¯o_go;
|
|
|
|
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;
|