From b6eea1138e2b726b4bac71473cb1b088ebc7581a Mon Sep 17 00:00:00 2001 From: MadMaurice Date: Thu, 1 Apr 2021 22:44:06 +0200 Subject: [PATCH] Initial revision. --- lib/Minilisp.pm | 321 ++++++++++++++++++++++++++++++++++++++++++++++++ test.pl | 21 ++++ 2 files changed, 342 insertions(+) create mode 100644 lib/Minilisp.pm create mode 100644 test.pl diff --git a/lib/Minilisp.pm b/lib/Minilisp.pm new file mode 100644 index 0000000..b1886be --- /dev/null +++ b/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} = \¯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; + + 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} = \¯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; + +sub compile { + my ($term) = @_; + my @tokens = tokenize($term); + my $parsed = parser(@tokens); + + return $parsed; +} + +1; diff --git a/test.pl b/test.pl new file mode 100644 index 0000000..1e21fe7 --- /dev/null +++ b/test.pl @@ -0,0 +1,21 @@ +use lib "./lib"; + +use Minilisp; +use Data::Dumper; + +my $term = < "bar", +}; + +print "$term\n"; +print ":= " . $parsed->($ctx) . "\n";