mirror of
https://github.com/kanaka/mal.git
synced 2024-09-19 17:47:53 +03:00
perl: backport all recent style changes from stepA to previous steps
This commit is contained in:
Nicolas Boulenguez
Joel Martin
parent
4e02e6231e
commit
87b0b23970
@ -1,9 +1,13 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use File::Basename;
|
||||
use lib dirname (__FILE__);
|
||||
use File::Basename 'dirname';
|
||||
use lib dirname(__FILE__);
|
||||
|
||||
use readline qw(mal_readline set_rl_mode);
|
||||
use English '-no_match_vars';
|
||||
|
||||
use Readline qw(mal_readline set_rl_mode);
|
||||
|
||||
# read
|
||||
sub READ {
|
||||
@ -13,7 +17,7 @@ sub READ {
|
||||
|
||||
# eval
|
||||
sub EVAL {
|
||||
my($ast, $env) = @_;
|
||||
my ($ast) = @_;
|
||||
return $ast;
|
||||
}
|
||||
|
||||
@ -26,14 +30,15 @@ sub PRINT {
|
||||
# repl
|
||||
sub REP {
|
||||
my $str = shift;
|
||||
return PRINT(EVAL(READ($str), {}));
|
||||
return PRINT( EVAL( READ($str) ) );
|
||||
}
|
||||
|
||||
if (scalar(@ARGV) > 0 && $ARGV[0] eq "--raw") {
|
||||
set_rl_mode("raw");
|
||||
# Command line arguments
|
||||
if ( $ARGV[0] eq '--raw' ) {
|
||||
set_rl_mode('raw');
|
||||
shift @ARGV;
|
||||
}
|
||||
while (1) {
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
print(REP($line), "\n");
|
||||
|
||||
while ( defined( my $line = mal_readline('user> ') ) ) {
|
||||
print REP($line), "\n" or die $ERRNO;
|
||||
}
|
||||
|
||||
@ -1,58 +1,52 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use File::Basename;
|
||||
use lib dirname (__FILE__);
|
||||
use File::Basename 'dirname';
|
||||
use lib dirname(__FILE__);
|
||||
|
||||
use Scalar::Util qw(blessed);
|
||||
use English '-no_match_vars';
|
||||
|
||||
use readline qw(mal_readline set_rl_mode);
|
||||
use reader;
|
||||
use printer;
|
||||
use Readline qw(mal_readline set_rl_mode);
|
||||
use Reader qw(read_str);
|
||||
use Printer qw(pr_str);
|
||||
|
||||
# read
|
||||
sub READ {
|
||||
my $str = shift;
|
||||
return reader::read_str($str);
|
||||
return read_str($str);
|
||||
}
|
||||
|
||||
# eval
|
||||
sub EVAL {
|
||||
my($ast, $env) = @_;
|
||||
my ($ast) = @_;
|
||||
return $ast;
|
||||
}
|
||||
|
||||
# print
|
||||
sub PRINT {
|
||||
my $exp = shift;
|
||||
return printer::_pr_str($exp);
|
||||
return pr_str($exp);
|
||||
}
|
||||
|
||||
# repl
|
||||
sub REP {
|
||||
my $str = shift;
|
||||
return PRINT(EVAL(READ($str), {}));
|
||||
return PRINT( EVAL( READ($str) ) );
|
||||
}
|
||||
|
||||
if (@ARGV && $ARGV[0] eq "--raw") {
|
||||
set_rl_mode("raw");
|
||||
# Command line arguments
|
||||
if ( $ARGV[0] eq '--raw' ) {
|
||||
set_rl_mode('raw');
|
||||
shift @ARGV;
|
||||
}
|
||||
while (1) {
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
if (defined(blessed $err) && $err->isa('Mal::BlankException')) {
|
||||
# ignore and continue
|
||||
} else {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
};
|
||||
|
||||
while ( defined( my $line = mal_readline('user> ') ) ) {
|
||||
eval {
|
||||
print REP($line), "\n" or die $ERRNO;
|
||||
1;
|
||||
} or do {
|
||||
my $err = $EVAL_ERROR;
|
||||
print 'Error: ', $err or die $ERRNO;
|
||||
};
|
||||
}
|
||||
|
||||
@ -1,86 +1,79 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use File::Basename;
|
||||
use lib dirname (__FILE__);
|
||||
use File::Basename 'dirname';
|
||||
use lib dirname(__FILE__);
|
||||
|
||||
use Data::Dumper;
|
||||
use English '-no_match_vars';
|
||||
use List::Util qw(pairmap);
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
use readline qw(mal_readline set_rl_mode);
|
||||
use types;
|
||||
use reader;
|
||||
use printer;
|
||||
use Readline qw(mal_readline set_rl_mode);
|
||||
use Types qw();
|
||||
use Reader qw(read_str);
|
||||
use Printer qw(pr_str);
|
||||
|
||||
# read
|
||||
sub READ {
|
||||
my $str = shift;
|
||||
return reader::read_str($str);
|
||||
return read_str($str);
|
||||
}
|
||||
|
||||
# eval
|
||||
sub EVAL {
|
||||
my($ast, $env) = @_;
|
||||
#print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
my ( $ast, $env ) = @_;
|
||||
|
||||
if ($ast->isa('Mal::Symbol')) {
|
||||
return $env->{$$ast} // die "'$$ast' not found\n";
|
||||
} elsif ($ast->isa('Mal::Vector')) {
|
||||
return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]);
|
||||
} elsif ($ast->isa('Mal::HashMap')) {
|
||||
return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast });
|
||||
} elsif (! $ast->isa('Mal::List')) {
|
||||
return $ast;
|
||||
#print 'EVAL: ', pr_str($ast), "\n" or die $ERRNO;
|
||||
|
||||
if ( $ast->isa('Mal::Symbol') ) {
|
||||
return $env->{ ${$ast} } // die "'${$ast}' not found\n";
|
||||
}
|
||||
|
||||
# apply list
|
||||
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
my $f = EVAL($a0, $env);
|
||||
my (undef, @args) = @$ast;
|
||||
return &$f(map { EVAL($_, $env) } @args);
|
||||
if ( $ast->isa('Mal::Vector') ) {
|
||||
return Mal::Vector->new( [ map { EVAL( $_, $env ) } @{$ast} ] );
|
||||
}
|
||||
if ( $ast->isa('Mal::HashMap') ) {
|
||||
return Mal::HashMap->new(
|
||||
{ pairmap { $a => EVAL( $b, $env ) } %{$ast} } );
|
||||
}
|
||||
if ( $ast->isa('Mal::List') and @{$ast} ) {
|
||||
my ( $a0, @args ) = @{$ast};
|
||||
my $f = EVAL( $a0, $env );
|
||||
return $f->( map { EVAL( $_, $env ) } @args );
|
||||
}
|
||||
return $ast;
|
||||
}
|
||||
|
||||
# print
|
||||
sub PRINT {
|
||||
my $exp = shift;
|
||||
return printer::_pr_str($exp);
|
||||
return pr_str($exp);
|
||||
}
|
||||
|
||||
# repl
|
||||
my $repl_env = {
|
||||
'+' => sub { Mal::Integer->new(${$_[0]} + ${$_[1]}) },
|
||||
'-' => sub { Mal::Integer->new(${$_[0]} - ${$_[1]}) },
|
||||
'*' => sub { Mal::Integer->new(${$_[0]} * ${$_[1]}) },
|
||||
'/' => sub { Mal::Integer->new(${$_[0]} / ${$_[1]}) },
|
||||
q{+} => sub { Mal::Integer->new( ${ $_[0] } + ${ $_[1] } ) },
|
||||
q{-} => sub { Mal::Integer->new( ${ $_[0] } - ${ $_[1] } ) },
|
||||
q{*} => sub { Mal::Integer->new( ${ $_[0] } * ${ $_[1] } ) },
|
||||
q{/} => sub { Mal::Integer->new( ${ $_[0] } / ${ $_[1] } ) },
|
||||
};
|
||||
|
||||
sub REP {
|
||||
my $str = shift;
|
||||
return PRINT(EVAL(READ($str), $repl_env));
|
||||
return PRINT( EVAL( READ($str), $repl_env ) );
|
||||
}
|
||||
|
||||
if (@ARGV && $ARGV[0] eq "--raw") {
|
||||
set_rl_mode("raw");
|
||||
# Command line arguments
|
||||
if ( $ARGV[0] eq '--raw' ) {
|
||||
set_rl_mode('raw');
|
||||
shift @ARGV;
|
||||
}
|
||||
while (1) {
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
if (defined(blessed $err) && $err->isa('Mal::BlankException')) {
|
||||
# ignore and continue
|
||||
} else {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
};
|
||||
|
||||
while ( defined( my $line = mal_readline('user> ') ) ) {
|
||||
eval {
|
||||
print REP($line), "\n" or die $ERRNO;
|
||||
1;
|
||||
} or do {
|
||||
my $err = $EVAL_ERROR;
|
||||
print 'Error: ', $err or die $ERRNO;
|
||||
};
|
||||
}
|
||||
|
||||
@ -1,115 +1,109 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
no if $] >= 5.018, warnings => "experimental::smartmatch";
|
||||
use feature qw(switch);
|
||||
use File::Basename;
|
||||
use lib dirname (__FILE__);
|
||||
use File::Basename 'dirname';
|
||||
use lib dirname(__FILE__);
|
||||
|
||||
use Data::Dumper;
|
||||
use English '-no_match_vars';
|
||||
use List::Util qw(pairs pairmap);
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
use readline qw(mal_readline set_rl_mode);
|
||||
use types qw($nil $false);
|
||||
use reader;
|
||||
use printer;
|
||||
use env;
|
||||
use Readline qw(mal_readline set_rl_mode);
|
||||
use Types qw(nil false);
|
||||
use Reader qw(read_str);
|
||||
use Printer qw(pr_str);
|
||||
use Env;
|
||||
|
||||
# read
|
||||
sub READ {
|
||||
my $str = shift;
|
||||
return reader::read_str($str);
|
||||
return read_str($str);
|
||||
}
|
||||
|
||||
# eval
|
||||
|
||||
my %special_forms = (
|
||||
'def!' => \&special_def,
|
||||
'let*' => \&special_let,
|
||||
);
|
||||
|
||||
sub EVAL {
|
||||
my($ast, $env) = @_;
|
||||
my ( $ast, $env ) = @_;
|
||||
|
||||
my $dbgeval = $env->get('DEBUG-EVAL');
|
||||
if ($dbgeval and $dbgeval ne $nil and $dbgeval ne $false) {
|
||||
print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
if ( $dbgeval
|
||||
and not $dbgeval->isa('Mal::Nil')
|
||||
and not $dbgeval->isa('Mal::False') )
|
||||
{
|
||||
print 'EVAL: ', pr_str($ast), "\n" or die $ERRNO;
|
||||
}
|
||||
|
||||
if ($ast->isa('Mal::Symbol')) {
|
||||
my $val = $env->get($$ast);
|
||||
die "'$$ast' not found\n" unless $val;
|
||||
return $val;
|
||||
} elsif ($ast->isa('Mal::Vector')) {
|
||||
return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]);
|
||||
} elsif ($ast->isa('Mal::HashMap')) {
|
||||
return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast });
|
||||
} elsif (! $ast->isa('Mal::List')) {
|
||||
return $ast;
|
||||
if ( $ast->isa('Mal::Symbol') ) {
|
||||
return $env->get( ${$ast} ) // die "'${$ast}' not found\n";
|
||||
}
|
||||
|
||||
# apply list
|
||||
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($$sym, EVAL($val, $env));
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($$k, EVAL($v, $let_env));
|
||||
}
|
||||
return EVAL($body, $let_env);
|
||||
}
|
||||
default {
|
||||
my $f = EVAL($a0, $env);
|
||||
my (undef, @args) = @$ast;
|
||||
return &$f(map { EVAL($_, $env) } @args);
|
||||
}
|
||||
if ( $ast->isa('Mal::Vector') ) {
|
||||
return Mal::Vector->new( [ map { EVAL( $_, $env ) } @{$ast} ] );
|
||||
}
|
||||
if ( $ast->isa('Mal::HashMap') ) {
|
||||
return Mal::HashMap->new(
|
||||
{ pairmap { $a => EVAL( $b, $env ) } %{$ast} } );
|
||||
}
|
||||
if ( $ast->isa('Mal::List') and @{$ast} ) {
|
||||
my ( $a0, @args ) = @{$ast};
|
||||
if ( $a0->isa('Mal::Symbol') and my $sf = $special_forms{ ${$a0} } ) {
|
||||
return $sf->( $env, @args );
|
||||
}
|
||||
my $f = EVAL( $a0, $env );
|
||||
return $f->( map { EVAL( $_, $env ) } @args );
|
||||
}
|
||||
return $ast;
|
||||
}
|
||||
|
||||
sub special_def {
|
||||
my ( $env, $sym, $val ) = @_;
|
||||
return $env->set( ${$sym}, EVAL( $val, $env ) );
|
||||
}
|
||||
|
||||
sub special_let {
|
||||
my ( $env, $bindings, $body ) = @_;
|
||||
my $let_env = Env->new($env);
|
||||
foreach my $pair ( pairs @{$bindings} ) {
|
||||
my ( $k, $v ) = @{$pair};
|
||||
$let_env->set( ${$k}, EVAL( $v, $let_env ) );
|
||||
}
|
||||
return EVAL( $body, $let_env );
|
||||
}
|
||||
|
||||
# print
|
||||
sub PRINT {
|
||||
my $exp = shift;
|
||||
return printer::_pr_str($exp);
|
||||
return pr_str($exp);
|
||||
}
|
||||
|
||||
# repl
|
||||
my $repl_env = Mal::Env->new();
|
||||
my $repl_env = Env->new();
|
||||
$repl_env->set( q{+}, sub { Mal::Integer->new( ${ $_[0] } + ${ $_[1] } ) } );
|
||||
$repl_env->set( q{-}, sub { Mal::Integer->new( ${ $_[0] } - ${ $_[1] } ) } );
|
||||
$repl_env->set( q{*}, sub { Mal::Integer->new( ${ $_[0] } * ${ $_[1] } ) } );
|
||||
$repl_env->set( q{/}, sub { Mal::Integer->new( ${ $_[0] } / ${ $_[1] } ) } );
|
||||
|
||||
sub REP {
|
||||
my $str = shift;
|
||||
return PRINT(EVAL(READ($str), $repl_env));
|
||||
return PRINT( EVAL( READ($str), $repl_env ) );
|
||||
}
|
||||
|
||||
$repl_env->set('+',
|
||||
sub { Mal::Integer->new(${$_[0]} + ${$_[1]}) } );
|
||||
$repl_env->set('-',
|
||||
sub { Mal::Integer->new(${$_[0]} - ${$_[1]}) } );
|
||||
$repl_env->set('*',
|
||||
sub { Mal::Integer->new(${$_[0]} * ${$_[1]}) } );
|
||||
$repl_env->set('/',
|
||||
sub { Mal::Integer->new(${$_[0]} / ${$_[1]}) } );
|
||||
|
||||
if (@ARGV && $ARGV[0] eq "--raw") {
|
||||
set_rl_mode("raw");
|
||||
# Command line arguments
|
||||
if ( $ARGV[0] eq '--raw' ) {
|
||||
set_rl_mode('raw');
|
||||
shift @ARGV;
|
||||
}
|
||||
while (1) {
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
if (defined(blessed $err) && $err->isa('Mal::BlankException')) {
|
||||
# ignore and continue
|
||||
} else {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
};
|
||||
|
||||
while ( defined( my $line = mal_readline('user> ') ) ) {
|
||||
eval {
|
||||
print REP($line), "\n" or die $ERRNO;
|
||||
1;
|
||||
} or do {
|
||||
my $err = $EVAL_ERROR;
|
||||
print 'Error: ', $err or die $ERRNO;
|
||||
};
|
||||
}
|
||||
|
||||
@ -1,137 +1,148 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
no if $] >= 5.018, warnings => "experimental::smartmatch";
|
||||
use feature qw(switch);
|
||||
use File::Basename;
|
||||
use lib dirname (__FILE__);
|
||||
use File::Basename 'dirname';
|
||||
use lib dirname(__FILE__);
|
||||
|
||||
use Data::Dumper;
|
||||
use English '-no_match_vars';
|
||||
use List::Util qw(pairs pairmap);
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
use readline qw(mal_readline set_rl_mode);
|
||||
use types qw($nil $true $false);
|
||||
use reader;
|
||||
use printer;
|
||||
use env;
|
||||
use core;
|
||||
use Readline qw(mal_readline set_rl_mode);
|
||||
use Types qw(nil false);
|
||||
use Reader qw(read_str);
|
||||
use Printer qw(pr_str);
|
||||
use Env;
|
||||
use Core qw(%NS);
|
||||
|
||||
# read
|
||||
sub READ {
|
||||
my $str = shift;
|
||||
return reader::read_str($str);
|
||||
return read_str($str);
|
||||
}
|
||||
|
||||
# eval
|
||||
|
||||
my %special_forms = (
|
||||
'def!' => \&special_def,
|
||||
'let*' => \&special_let,
|
||||
|
||||
'do' => \&special_do,
|
||||
'if' => \&special_if,
|
||||
'fn*' => \&special_fn,
|
||||
);
|
||||
|
||||
sub EVAL {
|
||||
my($ast, $env) = @_;
|
||||
my ( $ast, $env ) = @_;
|
||||
|
||||
my $dbgeval = $env->get('DEBUG-EVAL');
|
||||
if ($dbgeval and $dbgeval ne $nil and $dbgeval ne $false) {
|
||||
print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
if ( $dbgeval
|
||||
and not $dbgeval->isa('Mal::Nil')
|
||||
and not $dbgeval->isa('Mal::False') )
|
||||
{
|
||||
print 'EVAL: ', pr_str($ast), "\n" or die $ERRNO;
|
||||
}
|
||||
|
||||
if ($ast->isa('Mal::Symbol')) {
|
||||
my $val = $env->get($$ast);
|
||||
die "'$$ast' not found\n" unless $val;
|
||||
return $val;
|
||||
} elsif ($ast->isa('Mal::Vector')) {
|
||||
return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]);
|
||||
} elsif ($ast->isa('Mal::HashMap')) {
|
||||
return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast });
|
||||
} elsif (! $ast->isa('Mal::List')) {
|
||||
return $ast;
|
||||
if ( $ast->isa('Mal::Symbol') ) {
|
||||
return $env->get( ${$ast} ) // die "'${$ast}' not found\n";
|
||||
}
|
||||
|
||||
# apply list
|
||||
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($$sym, EVAL($val, $env));
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($$k, EVAL($v, $let_env));
|
||||
}
|
||||
return EVAL($body, $let_env);
|
||||
}
|
||||
when ('do') {
|
||||
my (undef, @todo) = @$ast;
|
||||
my $last = pop @todo;
|
||||
map { EVAL($_, $env) } @todo;
|
||||
return EVAL($last, $env);
|
||||
}
|
||||
when ('if') {
|
||||
my (undef, $if, $then, $else) = @$ast;
|
||||
my $cond = EVAL($if, $env);
|
||||
if ($cond eq $nil || $cond eq $false) {
|
||||
return $else ? EVAL($else, $env) : $nil;
|
||||
} else {
|
||||
return EVAL($then, $env);
|
||||
}
|
||||
}
|
||||
when ('fn*') {
|
||||
my (undef, $params, $body) = @$ast;
|
||||
return Mal::Function->new(sub {
|
||||
#print "running fn*\n";
|
||||
return EVAL($body, Mal::Env->new($env, $params, \@_));
|
||||
});
|
||||
}
|
||||
default {
|
||||
my $f = EVAL($a0, $env);
|
||||
my (undef, @args) = @$ast;
|
||||
return &$f(map { EVAL($_, $env) } @args);
|
||||
}
|
||||
if ( $ast->isa('Mal::Vector') ) {
|
||||
return Mal::Vector->new( [ map { EVAL( $_, $env ) } @{$ast} ] );
|
||||
}
|
||||
if ( $ast->isa('Mal::HashMap') ) {
|
||||
return Mal::HashMap->new(
|
||||
{ pairmap { $a => EVAL( $b, $env ) } %{$ast} } );
|
||||
}
|
||||
if ( $ast->isa('Mal::List') and @{$ast} ) {
|
||||
my ( $a0, @args ) = @{$ast};
|
||||
if ( $a0->isa('Mal::Symbol') and my $sf = $special_forms{ ${$a0} } ) {
|
||||
return $sf->( $env, @args );
|
||||
}
|
||||
my $f = EVAL( $a0, $env );
|
||||
return $f->( map { EVAL( $_, $env ) } @args );
|
||||
}
|
||||
return $ast;
|
||||
}
|
||||
|
||||
sub special_def {
|
||||
my ( $env, $sym, $val ) = @_;
|
||||
return $env->set( ${$sym}, EVAL( $val, $env ) );
|
||||
}
|
||||
|
||||
sub special_let {
|
||||
my ( $env, $bindings, $body ) = @_;
|
||||
my $let_env = Env->new($env);
|
||||
foreach my $pair ( pairs @{$bindings} ) {
|
||||
my ( $k, $v ) = @{$pair};
|
||||
$let_env->set( ${$k}, EVAL( $v, $let_env ) );
|
||||
}
|
||||
return EVAL( $body, $let_env );
|
||||
}
|
||||
|
||||
sub special_do {
|
||||
my ( $env, @todo ) = @_;
|
||||
my $final = pop @todo;
|
||||
for (@todo) {
|
||||
EVAL( $_, $env );
|
||||
}
|
||||
return EVAL( $final, $env );
|
||||
}
|
||||
|
||||
sub special_if {
|
||||
my ( $env, $if, $then, $else ) = @_;
|
||||
my $cond = EVAL( $if, $env );
|
||||
if ( not $cond->isa('Mal::Nil') and not $cond->isa('Mal::False') ) {
|
||||
return EVAL( $then, $env );
|
||||
}
|
||||
if ($else) {
|
||||
return EVAL( $else, $env );
|
||||
}
|
||||
return nil;
|
||||
}
|
||||
|
||||
sub special_fn {
|
||||
my ( $env, $params, $body ) = @_;
|
||||
return Mal::Function->new(
|
||||
sub {
|
||||
return EVAL( $body, Env->new( $env, $params, \@_ ) );
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
# print
|
||||
sub PRINT {
|
||||
my $exp = shift;
|
||||
return printer::_pr_str($exp);
|
||||
return pr_str($exp);
|
||||
}
|
||||
|
||||
# repl
|
||||
my $repl_env = Mal::Env->new();
|
||||
my $repl_env = Env->new();
|
||||
|
||||
sub REP {
|
||||
my $str = shift;
|
||||
return PRINT(EVAL(READ($str), $repl_env));
|
||||
return PRINT( EVAL( READ($str), $repl_env ) );
|
||||
}
|
||||
|
||||
# Command line arguments
|
||||
if ( $ARGV[0] eq '--raw' ) {
|
||||
set_rl_mode('raw');
|
||||
shift @ARGV;
|
||||
}
|
||||
|
||||
# core.pl: defined using perl
|
||||
foreach my $n (keys %core::ns) {
|
||||
$repl_env->set($n, $core::ns{$n});
|
||||
while ( my ( $k, $v ) = each %NS ) {
|
||||
$repl_env->set( $k, Mal::Function->new($v) );
|
||||
}
|
||||
|
||||
# core.mal: defined using the language itself
|
||||
REP(q[(def! not (fn* (a) (if a false true)))]);
|
||||
|
||||
if (@ARGV && $ARGV[0] eq "--raw") {
|
||||
set_rl_mode("raw");
|
||||
}
|
||||
while (1) {
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
if (defined(blessed $err) && $err->isa('Mal::BlankException')) {
|
||||
# ignore and continue
|
||||
} else {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
};
|
||||
while ( defined( my $line = mal_readline('user> ') ) ) {
|
||||
eval {
|
||||
print REP($line), "\n" or die $ERRNO;
|
||||
1;
|
||||
} or do {
|
||||
my $err = $EVAL_ERROR;
|
||||
print 'Error: ', $err or die $ERRNO;
|
||||
};
|
||||
}
|
||||
|
||||
@ -1,142 +1,158 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings FATAL => "recursion";
|
||||
no if $] >= 5.018, warnings => "experimental::smartmatch";
|
||||
use feature qw(switch);
|
||||
use File::Basename;
|
||||
use lib dirname (__FILE__);
|
||||
use warnings FATAL => 'recursion';
|
||||
use File::Basename 'dirname';
|
||||
use lib dirname(__FILE__);
|
||||
|
||||
use Data::Dumper;
|
||||
use English '-no_match_vars';
|
||||
use List::Util qw(pairs pairmap);
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
use readline qw(mal_readline set_rl_mode);
|
||||
use types qw($nil $true $false);
|
||||
use reader;
|
||||
use printer;
|
||||
use env;
|
||||
use core;
|
||||
use Readline qw(mal_readline set_rl_mode);
|
||||
use Types qw(nil false);
|
||||
use Reader qw(read_str);
|
||||
use Printer qw(pr_str);
|
||||
use Env;
|
||||
use Core qw(%NS);
|
||||
|
||||
# False positives because of TCO.
|
||||
## no critic (Subroutines::RequireArgUnpacking)
|
||||
|
||||
# read
|
||||
sub READ {
|
||||
my $str = shift;
|
||||
return reader::read_str($str);
|
||||
return read_str($str);
|
||||
}
|
||||
|
||||
# eval
|
||||
|
||||
my %special_forms = (
|
||||
'def!' => \&special_def,
|
||||
'let*' => \&special_let,
|
||||
|
||||
'do' => \&special_do,
|
||||
'if' => \&special_if,
|
||||
'fn*' => \&special_fn,
|
||||
);
|
||||
|
||||
sub EVAL {
|
||||
my($ast, $env) = @_;
|
||||
my ( $ast, $env ) = @_;
|
||||
|
||||
my $dbgeval = $env->get('DEBUG-EVAL');
|
||||
if ($dbgeval and $dbgeval ne $nil and $dbgeval ne $false) {
|
||||
print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
if ( $dbgeval
|
||||
and not $dbgeval->isa('Mal::Nil')
|
||||
and not $dbgeval->isa('Mal::False') )
|
||||
{
|
||||
print 'EVAL: ', pr_str($ast), "\n" or die $ERRNO;
|
||||
}
|
||||
|
||||
if ($ast->isa('Mal::Symbol')) {
|
||||
my $val = $env->get($$ast);
|
||||
die "'$$ast' not found\n" unless $val;
|
||||
return $val;
|
||||
} elsif ($ast->isa('Mal::Vector')) {
|
||||
return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]);
|
||||
} elsif ($ast->isa('Mal::HashMap')) {
|
||||
return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast });
|
||||
} elsif (! $ast->isa('Mal::List')) {
|
||||
return $ast;
|
||||
if ( $ast->isa('Mal::Symbol') ) {
|
||||
return $env->get( ${$ast} ) // die "'${$ast}' not found\n";
|
||||
}
|
||||
|
||||
# apply list
|
||||
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($$sym, EVAL($val, $env));
|
||||
if ( $ast->isa('Mal::Vector') ) {
|
||||
return Mal::Vector->new( [ map { EVAL( $_, $env ) } @{$ast} ] );
|
||||
}
|
||||
if ( $ast->isa('Mal::HashMap') ) {
|
||||
return Mal::HashMap->new(
|
||||
{ pairmap { $a => EVAL( $b, $env ) } %{$ast} } );
|
||||
}
|
||||
if ( $ast->isa('Mal::List') and @{$ast} ) {
|
||||
my ( $a0, @args ) = @{$ast};
|
||||
if ( $a0->isa('Mal::Symbol') and my $sf = $special_forms{ ${$a0} } ) {
|
||||
@_ = ( $env, @args );
|
||||
goto &{$sf};
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($$k, EVAL($v, $let_env));
|
||||
}
|
||||
@_ = ($body, $let_env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('do') {
|
||||
my (undef, @todo) = @$ast;
|
||||
my $last = pop @todo;
|
||||
map { EVAL($_, $env) } @todo;
|
||||
@_ = ($last, $env);
|
||||
my $f = EVAL( $a0, $env );
|
||||
@_ = map { EVAL( $_, $env ) } @args;
|
||||
goto &{$f};
|
||||
}
|
||||
return $ast;
|
||||
}
|
||||
|
||||
sub special_def {
|
||||
my ( $env, $sym, $val ) = @_;
|
||||
return $env->set( ${$sym}, EVAL( $val, $env ) );
|
||||
}
|
||||
|
||||
sub special_let {
|
||||
my ( $env, $bindings, $body ) = @_;
|
||||
my $let_env = Env->new($env);
|
||||
foreach my $pair ( pairs @{$bindings} ) {
|
||||
my ( $k, $v ) = @{$pair};
|
||||
$let_env->set( ${$k}, EVAL( $v, $let_env ) );
|
||||
}
|
||||
@_ = ( $body, $let_env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_do {
|
||||
my ( $env, @todo ) = @_;
|
||||
my $final = pop @todo;
|
||||
for (@todo) {
|
||||
EVAL( $_, $env );
|
||||
}
|
||||
@_ = ( $final, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_if {
|
||||
my ( $env, $if, $then, $else ) = @_;
|
||||
my $cond = EVAL( $if, $env );
|
||||
if ( not $cond->isa('Mal::Nil') and not $cond->isa('Mal::False') ) {
|
||||
@_ = ( $then, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
if ($else) {
|
||||
@_ = ( $else, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
return nil;
|
||||
}
|
||||
|
||||
sub special_fn {
|
||||
my ( $env, $params, $body ) = @_;
|
||||
return Mal::Function->new(
|
||||
sub {
|
||||
@_ = ( $body, Env->new( $env, $params, \@_ ) );
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('if') {
|
||||
my (undef, $if, $then, $else) = @$ast;
|
||||
my $cond = EVAL($if, $env);
|
||||
if ($cond eq $nil || $cond eq $false) {
|
||||
@_ = ($else // $nil, $env);
|
||||
} else {
|
||||
@_ = ($then, $env);
|
||||
}
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('fn*') {
|
||||
my (undef, $params, $body) = @$ast;
|
||||
return Mal::Function->new(sub {
|
||||
#print "running fn*\n";
|
||||
@_ = ($body, Mal::Env->new($env, $params, \@_));
|
||||
goto &EVAL;
|
||||
});
|
||||
}
|
||||
default {
|
||||
my $f = EVAL($a0, $env);
|
||||
my (undef, @args) = @$ast;
|
||||
@_ = map { EVAL($_, $env) } @args;
|
||||
goto &$f;
|
||||
}
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
# print
|
||||
sub PRINT {
|
||||
my $exp = shift;
|
||||
return printer::_pr_str($exp);
|
||||
return pr_str($exp);
|
||||
}
|
||||
|
||||
# repl
|
||||
my $repl_env = Mal::Env->new();
|
||||
my $repl_env = Env->new();
|
||||
|
||||
sub REP {
|
||||
my $str = shift;
|
||||
return PRINT(EVAL(READ($str), $repl_env));
|
||||
return PRINT( EVAL( READ($str), $repl_env ) );
|
||||
}
|
||||
|
||||
# Command line arguments
|
||||
if ( $ARGV[0] eq '--raw' ) {
|
||||
set_rl_mode('raw');
|
||||
shift @ARGV;
|
||||
}
|
||||
|
||||
# core.pl: defined using perl
|
||||
foreach my $n (keys %core::ns) {
|
||||
$repl_env->set($n, $core::ns{$n});
|
||||
while ( my ( $k, $v ) = each %NS ) {
|
||||
$repl_env->set( $k, Mal::Function->new($v) );
|
||||
}
|
||||
|
||||
# core.mal: defined using the language itself
|
||||
REP(q[(def! not (fn* (a) (if a false true)))]);
|
||||
|
||||
if (@ARGV && $ARGV[0] eq "--raw") {
|
||||
set_rl_mode("raw");
|
||||
}
|
||||
while (1) {
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
if (defined(blessed $err) && $err->isa('Mal::BlankException')) {
|
||||
# ignore and continue
|
||||
} else {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
};
|
||||
while ( defined( my $line = mal_readline('user> ') ) ) {
|
||||
eval {
|
||||
print REP($line), "\n" or die $ERRNO;
|
||||
1;
|
||||
} or do {
|
||||
my $err = $EVAL_ERROR;
|
||||
print 'Error: ', $err or die $ERRNO;
|
||||
};
|
||||
}
|
||||
|
||||
@ -1,152 +1,170 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings FATAL => "recursion";
|
||||
no if $] >= 5.018, warnings => "experimental::smartmatch";
|
||||
use feature qw(switch);
|
||||
use File::Basename;
|
||||
use lib dirname (__FILE__);
|
||||
use warnings FATAL => 'recursion';
|
||||
use File::Basename 'dirname';
|
||||
use lib dirname(__FILE__);
|
||||
|
||||
use Data::Dumper;
|
||||
use English '-no_match_vars';
|
||||
use List::Util qw(pairs pairmap);
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
use readline qw(mal_readline set_rl_mode);
|
||||
use types qw($nil $true $false);
|
||||
use reader;
|
||||
use printer;
|
||||
use env;
|
||||
use core;
|
||||
use Readline qw(mal_readline set_rl_mode);
|
||||
use Types qw(nil false);
|
||||
use Reader qw(read_str);
|
||||
use Printer qw(pr_str);
|
||||
use Env;
|
||||
use Core qw(%NS);
|
||||
|
||||
# False positives because of TCO.
|
||||
## no critic (Subroutines::RequireArgUnpacking)
|
||||
|
||||
# read
|
||||
sub READ {
|
||||
my $str = shift;
|
||||
return reader::read_str($str);
|
||||
return read_str($str);
|
||||
}
|
||||
|
||||
# eval
|
||||
|
||||
my %special_forms = (
|
||||
'def!' => \&special_def,
|
||||
'let*' => \&special_let,
|
||||
|
||||
'do' => \&special_do,
|
||||
'if' => \&special_if,
|
||||
'fn*' => \&special_fn,
|
||||
);
|
||||
|
||||
sub EVAL {
|
||||
my($ast, $env) = @_;
|
||||
my ( $ast, $env ) = @_;
|
||||
|
||||
my $dbgeval = $env->get('DEBUG-EVAL');
|
||||
if ($dbgeval and $dbgeval ne $nil and $dbgeval ne $false) {
|
||||
print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
if ( $dbgeval
|
||||
and not $dbgeval->isa('Mal::Nil')
|
||||
and not $dbgeval->isa('Mal::False') )
|
||||
{
|
||||
print 'EVAL: ', pr_str($ast), "\n" or die $ERRNO;
|
||||
}
|
||||
|
||||
if ($ast->isa('Mal::Symbol')) {
|
||||
my $val = $env->get($$ast);
|
||||
die "'$$ast' not found\n" unless $val;
|
||||
return $val;
|
||||
} elsif ($ast->isa('Mal::Vector')) {
|
||||
return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]);
|
||||
} elsif ($ast->isa('Mal::HashMap')) {
|
||||
return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast });
|
||||
} elsif (! $ast->isa('Mal::List')) {
|
||||
return $ast;
|
||||
if ( $ast->isa('Mal::Symbol') ) {
|
||||
return $env->get( ${$ast} ) // die "'${$ast}' not found\n";
|
||||
}
|
||||
|
||||
# apply list
|
||||
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($$sym, EVAL($val, $env));
|
||||
if ( $ast->isa('Mal::Vector') ) {
|
||||
return Mal::Vector->new( [ map { EVAL( $_, $env ) } @{$ast} ] );
|
||||
}
|
||||
if ( $ast->isa('Mal::HashMap') ) {
|
||||
return Mal::HashMap->new(
|
||||
{ pairmap { $a => EVAL( $b, $env ) } %{$ast} } );
|
||||
}
|
||||
if ( $ast->isa('Mal::List') and @{$ast} ) {
|
||||
my ( $a0, @args ) = @{$ast};
|
||||
if ( $a0->isa('Mal::Symbol') and my $sf = $special_forms{ ${$a0} } ) {
|
||||
@_ = ( $env, @args );
|
||||
goto &{$sf};
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($$k, EVAL($v, $let_env));
|
||||
}
|
||||
@_ = ($body, $let_env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('do') {
|
||||
my (undef, @todo) = @$ast;
|
||||
my $last = pop @todo;
|
||||
map { EVAL($_, $env) } @todo;
|
||||
@_ = ($last, $env);
|
||||
my $f = EVAL( $a0, $env );
|
||||
@_ = map { EVAL( $_, $env ) } @args;
|
||||
goto &{$f};
|
||||
}
|
||||
return $ast;
|
||||
}
|
||||
|
||||
sub special_def {
|
||||
my ( $env, $sym, $val ) = @_;
|
||||
return $env->set( ${$sym}, EVAL( $val, $env ) );
|
||||
}
|
||||
|
||||
sub special_let {
|
||||
my ( $env, $bindings, $body ) = @_;
|
||||
my $let_env = Env->new($env);
|
||||
foreach my $pair ( pairs @{$bindings} ) {
|
||||
my ( $k, $v ) = @{$pair};
|
||||
$let_env->set( ${$k}, EVAL( $v, $let_env ) );
|
||||
}
|
||||
@_ = ( $body, $let_env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_do {
|
||||
my ( $env, @todo ) = @_;
|
||||
my $final = pop @todo;
|
||||
for (@todo) {
|
||||
EVAL( $_, $env );
|
||||
}
|
||||
@_ = ( $final, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_if {
|
||||
my ( $env, $if, $then, $else ) = @_;
|
||||
my $cond = EVAL( $if, $env );
|
||||
if ( not $cond->isa('Mal::Nil') and not $cond->isa('Mal::False') ) {
|
||||
@_ = ( $then, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
if ($else) {
|
||||
@_ = ( $else, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
return nil;
|
||||
}
|
||||
|
||||
sub special_fn {
|
||||
my ( $env, $params, $body ) = @_;
|
||||
return Mal::Function->new(
|
||||
sub {
|
||||
@_ = ( $body, Env->new( $env, $params, \@_ ) );
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('if') {
|
||||
my (undef, $if, $then, $else) = @$ast;
|
||||
my $cond = EVAL($if, $env);
|
||||
if ($cond eq $nil || $cond eq $false) {
|
||||
@_ = ($else // $nil, $env);
|
||||
} else {
|
||||
@_ = ($then, $env);
|
||||
}
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('fn*') {
|
||||
my (undef, $params, $body) = @$ast;
|
||||
return Mal::Function->new(sub {
|
||||
#print "running fn*\n";
|
||||
@_ = ($body, Mal::Env->new($env, $params, \@_));
|
||||
goto &EVAL;
|
||||
});
|
||||
}
|
||||
default {
|
||||
my $f = EVAL($a0, $env);
|
||||
my (undef, @args) = @$ast;
|
||||
@_ = map { EVAL($_, $env) } @args;
|
||||
goto &$f;
|
||||
}
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
# print
|
||||
sub PRINT {
|
||||
my $exp = shift;
|
||||
return printer::_pr_str($exp);
|
||||
return pr_str($exp);
|
||||
}
|
||||
|
||||
# repl
|
||||
my $repl_env = Mal::Env->new();
|
||||
my $repl_env = Env->new();
|
||||
|
||||
sub REP {
|
||||
my $str = shift;
|
||||
return PRINT(EVAL(READ($str), $repl_env));
|
||||
return PRINT( EVAL( READ($str), $repl_env ) );
|
||||
}
|
||||
|
||||
# core.pl: defined using perl
|
||||
foreach my $n (keys %core::ns) {
|
||||
$repl_env->set($n, $core::ns{$n});
|
||||
# Command line arguments
|
||||
if ( $ARGV[0] eq '--raw' ) {
|
||||
set_rl_mode('raw');
|
||||
shift @ARGV;
|
||||
}
|
||||
$repl_env->set('eval',
|
||||
Mal::Function->new(sub { EVAL($_[0], $repl_env) }));
|
||||
my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV];
|
||||
$repl_env->set('*ARGV*', Mal::List->new(\@_argv));
|
||||
my $script_file = shift @ARGV;
|
||||
|
||||
# core.pl: defined using perl
|
||||
while ( my ( $k, $v ) = each %NS ) {
|
||||
$repl_env->set( $k, Mal::Function->new($v) );
|
||||
}
|
||||
$repl_env->set( 'eval',
|
||||
Mal::Function->new( sub { EVAL( $_[0], $repl_env ) } ) );
|
||||
$repl_env->set( '*ARGV*',
|
||||
Mal::List->new( [ map { Mal::String->new($_) } @ARGV ] ) );
|
||||
|
||||
# core.mal: defined using the language itself
|
||||
REP(q[(def! not (fn* (a) (if a false true)))]);
|
||||
REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]);
|
||||
REP(<<'EOF');
|
||||
(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))
|
||||
EOF
|
||||
|
||||
if (@ARGV && $ARGV[0] eq "--raw") {
|
||||
set_rl_mode("raw");
|
||||
shift @ARGV;
|
||||
}
|
||||
if (@ARGV) {
|
||||
REP(qq[(load-file "$ARGV[0]")]);
|
||||
if ( defined $script_file ) {
|
||||
REP(qq[(load-file "$script_file")]);
|
||||
exit 0;
|
||||
}
|
||||
while (1) {
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
if (defined(blessed $err) && $err->isa('Mal::BlankException')) {
|
||||
# ignore and continue
|
||||
} else {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
};
|
||||
while ( defined( my $line = mal_readline('user> ') ) ) {
|
||||
eval {
|
||||
print REP($line), "\n" or die $ERRNO;
|
||||
1;
|
||||
} or do {
|
||||
my $err = $EVAL_ERROR;
|
||||
print 'Error: ', $err or die $ERRNO;
|
||||
};
|
||||
}
|
||||
|
||||
@ -1,190 +1,223 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings FATAL => "recursion";
|
||||
no if $] >= 5.018, warnings => "experimental::smartmatch";
|
||||
use feature qw(switch);
|
||||
use File::Basename;
|
||||
use lib dirname (__FILE__);
|
||||
use warnings FATAL => 'recursion';
|
||||
use File::Basename 'dirname';
|
||||
use lib dirname(__FILE__);
|
||||
|
||||
use Data::Dumper;
|
||||
use English '-no_match_vars';
|
||||
use List::Util qw(pairs pairmap);
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
use readline qw(mal_readline set_rl_mode);
|
||||
use types qw($nil $true $false);
|
||||
use reader;
|
||||
use printer;
|
||||
use env;
|
||||
use core;
|
||||
use Readline qw(mal_readline set_rl_mode);
|
||||
use Types qw(nil false);
|
||||
use Reader qw(read_str);
|
||||
use Printer qw(pr_str);
|
||||
use Env;
|
||||
use Core qw(%NS);
|
||||
|
||||
# False positives because of TCO.
|
||||
## no critic (Subroutines::RequireArgUnpacking)
|
||||
|
||||
# read
|
||||
sub READ {
|
||||
my $str = shift;
|
||||
return reader::read_str($str);
|
||||
return read_str($str);
|
||||
}
|
||||
|
||||
# eval
|
||||
sub starts_with {
|
||||
my ($ast, $sym) = @_;
|
||||
return @$ast && $ast->[0]->isa('Mal::Symbol') && ${$ast->[0]} eq $sym;
|
||||
my ( $ast, $sym ) = @_;
|
||||
return @{$ast} && $ast->[0]->isa('Mal::Symbol') && ${ $ast->[0] } eq $sym;
|
||||
}
|
||||
|
||||
sub quasiquote_loop {
|
||||
my ($ast) = @_;
|
||||
my $res = Mal::List->new([]);
|
||||
foreach my $elt (reverse @$ast) {
|
||||
if ($elt->isa('Mal::List') and starts_with($elt, 'splice-unquote')) {
|
||||
$res = Mal::List->new([Mal::Symbol->new('concat'), $elt->[1], $res]);
|
||||
} else {
|
||||
$res = Mal::List->new([Mal::Symbol->new('cons'), quasiquote($elt), $res]);
|
||||
my $res = Mal::List->new( [] );
|
||||
foreach my $elt ( reverse @{$ast} ) {
|
||||
if ( $elt->isa('Mal::List') and starts_with( $elt, 'splice-unquote' ) )
|
||||
{
|
||||
$res =
|
||||
Mal::List->new( [ Mal::Symbol->new('concat'), $elt->[1], $res ] );
|
||||
}
|
||||
else {
|
||||
$res = Mal::List->new(
|
||||
[ Mal::Symbol->new('cons'), quasiquote($elt), $res ] );
|
||||
}
|
||||
}
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub quasiquote {
|
||||
my ($ast) = @_;
|
||||
if ($ast->isa('Mal::Vector')) {
|
||||
return Mal::List->new([Mal::Symbol->new('vec'), quasiquote_loop($ast)]);
|
||||
} elsif ($ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol')) {
|
||||
return Mal::List->new([Mal::Symbol->new("quote"), $ast]);
|
||||
} elsif (!$ast->isa('Mal::List')) {
|
||||
return $ast;
|
||||
} elsif (starts_with($ast, 'unquote')) {
|
||||
return $ast->[1];
|
||||
} else {
|
||||
return quasiquote_loop($ast);
|
||||
if ( $ast->isa('Mal::Vector') ) {
|
||||
return Mal::List->new(
|
||||
[ Mal::Symbol->new('vec'), quasiquote_loop($ast) ] );
|
||||
}
|
||||
}
|
||||
|
||||
sub EVAL {
|
||||
my($ast, $env) = @_;
|
||||
|
||||
my $dbgeval = $env->get('DEBUG-EVAL');
|
||||
if ($dbgeval and $dbgeval ne $nil and $dbgeval ne $false) {
|
||||
print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
if ( $ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol') ) {
|
||||
return Mal::List->new( [ Mal::Symbol->new('quote'), $ast ] );
|
||||
}
|
||||
|
||||
if ($ast->isa('Mal::Symbol')) {
|
||||
my $val = $env->get($$ast);
|
||||
die "'$$ast' not found\n" unless $val;
|
||||
return $val;
|
||||
} elsif ($ast->isa('Mal::Vector')) {
|
||||
return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]);
|
||||
} elsif ($ast->isa('Mal::HashMap')) {
|
||||
return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast });
|
||||
} elsif (! $ast->isa('Mal::List')) {
|
||||
return $ast;
|
||||
}
|
||||
|
||||
# apply list
|
||||
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($$sym, EVAL($val, $env));
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($$k, EVAL($v, $let_env));
|
||||
}
|
||||
@_ = ($body, $let_env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('quote') {
|
||||
if ( $ast->isa('Mal::List') ) {
|
||||
if ( starts_with( $ast, 'unquote' ) ) {
|
||||
return $ast->[1];
|
||||
}
|
||||
when ('quasiquote') {
|
||||
@_ = (quasiquote($ast->[1]), $env);
|
||||
goto &EVAL;
|
||||
return quasiquote_loop($ast);
|
||||
}
|
||||
return $ast;
|
||||
}
|
||||
|
||||
my %special_forms = (
|
||||
'def!' => \&special_def,
|
||||
'let*' => \&special_let,
|
||||
|
||||
'do' => \&special_do,
|
||||
'if' => \&special_if,
|
||||
'fn*' => \&special_fn,
|
||||
|
||||
'quasiquote' => \&special_quasiquote,
|
||||
'quote' => \&special_quote,
|
||||
);
|
||||
|
||||
sub EVAL {
|
||||
my ( $ast, $env ) = @_;
|
||||
|
||||
my $dbgeval = $env->get('DEBUG-EVAL');
|
||||
if ( $dbgeval
|
||||
and not $dbgeval->isa('Mal::Nil')
|
||||
and not $dbgeval->isa('Mal::False') )
|
||||
{
|
||||
print 'EVAL: ', pr_str($ast), "\n" or die $ERRNO;
|
||||
}
|
||||
|
||||
if ( $ast->isa('Mal::Symbol') ) {
|
||||
return $env->get( ${$ast} ) // die "'${$ast}' not found\n";
|
||||
}
|
||||
if ( $ast->isa('Mal::Vector') ) {
|
||||
return Mal::Vector->new( [ map { EVAL( $_, $env ) } @{$ast} ] );
|
||||
}
|
||||
if ( $ast->isa('Mal::HashMap') ) {
|
||||
return Mal::HashMap->new(
|
||||
{ pairmap { $a => EVAL( $b, $env ) } %{$ast} } );
|
||||
}
|
||||
if ( $ast->isa('Mal::List') and @{$ast} ) {
|
||||
my ( $a0, @args ) = @{$ast};
|
||||
if ( $a0->isa('Mal::Symbol') and my $sf = $special_forms{ ${$a0} } ) {
|
||||
@_ = ( $env, @args );
|
||||
goto &{$sf};
|
||||
}
|
||||
when ('do') {
|
||||
my (undef, @todo) = @$ast;
|
||||
my $last = pop @todo;
|
||||
map { EVAL($_, $env) } @todo;
|
||||
@_ = ($last, $env);
|
||||
my $f = EVAL( $a0, $env );
|
||||
@_ = map { EVAL( $_, $env ) } @args;
|
||||
goto &{$f};
|
||||
}
|
||||
return $ast;
|
||||
}
|
||||
|
||||
sub special_def {
|
||||
my ( $env, $sym, $val ) = @_;
|
||||
return $env->set( ${$sym}, EVAL( $val, $env ) );
|
||||
}
|
||||
|
||||
sub special_let {
|
||||
my ( $env, $bindings, $body ) = @_;
|
||||
my $let_env = Env->new($env);
|
||||
foreach my $pair ( pairs @{$bindings} ) {
|
||||
my ( $k, $v ) = @{$pair};
|
||||
$let_env->set( ${$k}, EVAL( $v, $let_env ) );
|
||||
}
|
||||
@_ = ( $body, $let_env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_quote {
|
||||
my ( $env, $quoted ) = @_;
|
||||
return $quoted;
|
||||
}
|
||||
|
||||
sub special_quasiquote {
|
||||
my ( $env, $quoted ) = @_;
|
||||
@_ = ( quasiquote($quoted), $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_do {
|
||||
my ( $env, @todo ) = @_;
|
||||
my $final = pop @todo;
|
||||
for (@todo) {
|
||||
EVAL( $_, $env );
|
||||
}
|
||||
@_ = ( $final, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_if {
|
||||
my ( $env, $if, $then, $else ) = @_;
|
||||
my $cond = EVAL( $if, $env );
|
||||
if ( not $cond->isa('Mal::Nil') and not $cond->isa('Mal::False') ) {
|
||||
@_ = ( $then, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
if ($else) {
|
||||
@_ = ( $else, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
return nil;
|
||||
}
|
||||
|
||||
sub special_fn {
|
||||
my ( $env, $params, $body ) = @_;
|
||||
return Mal::Function->new(
|
||||
sub {
|
||||
@_ = ( $body, Env->new( $env, $params, \@_ ) );
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('if') {
|
||||
my (undef, $if, $then, $else) = @$ast;
|
||||
my $cond = EVAL($if, $env);
|
||||
if ($cond eq $nil || $cond eq $false) {
|
||||
@_ = ($else // $nil, $env);
|
||||
} else {
|
||||
@_ = ($then, $env);
|
||||
}
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('fn*') {
|
||||
my (undef, $params, $body) = @$ast;
|
||||
return Mal::Function->new(sub {
|
||||
#print "running fn*\n";
|
||||
@_ = ($body, Mal::Env->new($env, $params, \@_));
|
||||
goto &EVAL;
|
||||
});
|
||||
}
|
||||
default {
|
||||
my $f = EVAL($a0, $env);
|
||||
my (undef, @args) = @$ast;
|
||||
@_ = map { EVAL($_, $env) } @args;
|
||||
goto &$f;
|
||||
}
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
# print
|
||||
sub PRINT {
|
||||
my $exp = shift;
|
||||
return printer::_pr_str($exp);
|
||||
return pr_str($exp);
|
||||
}
|
||||
|
||||
# repl
|
||||
my $repl_env = Mal::Env->new();
|
||||
my $repl_env = Env->new();
|
||||
|
||||
sub REP {
|
||||
my $str = shift;
|
||||
return PRINT(EVAL(READ($str), $repl_env));
|
||||
return PRINT( EVAL( READ($str), $repl_env ) );
|
||||
}
|
||||
|
||||
# core.pl: defined using perl
|
||||
foreach my $n (keys %core::ns) {
|
||||
$repl_env->set($n, $core::ns{$n});
|
||||
# Command line arguments
|
||||
if ( $ARGV[0] eq '--raw' ) {
|
||||
set_rl_mode('raw');
|
||||
shift @ARGV;
|
||||
}
|
||||
$repl_env->set('eval',
|
||||
Mal::Function->new(sub { EVAL($_[0], $repl_env) }));
|
||||
my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV];
|
||||
$repl_env->set('*ARGV*', Mal::List->new(\@_argv));
|
||||
my $script_file = shift @ARGV;
|
||||
|
||||
# core.pl: defined using perl
|
||||
while ( my ( $k, $v ) = each %NS ) {
|
||||
$repl_env->set( $k, Mal::Function->new($v) );
|
||||
}
|
||||
$repl_env->set( 'eval',
|
||||
Mal::Function->new( sub { EVAL( $_[0], $repl_env ) } ) );
|
||||
$repl_env->set( '*ARGV*',
|
||||
Mal::List->new( [ map { Mal::String->new($_) } @ARGV ] ) );
|
||||
|
||||
# core.mal: defined using the language itself
|
||||
REP(q[(def! not (fn* (a) (if a false true)))]);
|
||||
REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]);
|
||||
REP(<<'EOF');
|
||||
(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))
|
||||
EOF
|
||||
|
||||
if (@ARGV && $ARGV[0] eq "--raw") {
|
||||
set_rl_mode("raw");
|
||||
shift @ARGV;
|
||||
}
|
||||
if (@ARGV) {
|
||||
REP(qq[(load-file "$ARGV[0]")]);
|
||||
if ( defined $script_file ) {
|
||||
REP(qq[(load-file "$script_file")]);
|
||||
exit 0;
|
||||
}
|
||||
while (1) {
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
if (defined(blessed $err) && $err->isa('Mal::BlankException')) {
|
||||
# ignore and continue
|
||||
} else {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
};
|
||||
while ( defined( my $line = mal_readline('user> ') ) ) {
|
||||
eval {
|
||||
print REP($line), "\n" or die $ERRNO;
|
||||
1;
|
||||
} or do {
|
||||
my $err = $EVAL_ERROR;
|
||||
print 'Error: ', $err or die $ERRNO;
|
||||
};
|
||||
}
|
||||
|
||||
@ -1,199 +1,239 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings FATAL => "recursion";
|
||||
no if $] >= 5.018, warnings => "experimental::smartmatch";
|
||||
use feature qw(switch);
|
||||
use File::Basename;
|
||||
use lib dirname (__FILE__);
|
||||
use warnings FATAL => 'recursion';
|
||||
use File::Basename 'dirname';
|
||||
use lib dirname(__FILE__);
|
||||
|
||||
use Data::Dumper;
|
||||
use English '-no_match_vars';
|
||||
use List::Util qw(pairs pairmap);
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
use readline qw(mal_readline set_rl_mode);
|
||||
use types qw($nil $true $false);
|
||||
use reader;
|
||||
use printer;
|
||||
use env;
|
||||
use core;
|
||||
use Readline qw(mal_readline set_rl_mode);
|
||||
use Types qw(nil false);
|
||||
use Reader qw(read_str);
|
||||
use Printer qw(pr_str);
|
||||
use Env;
|
||||
use Core qw(%NS);
|
||||
|
||||
# False positives because of TCO.
|
||||
## no critic (Subroutines::RequireArgUnpacking)
|
||||
|
||||
# read
|
||||
sub READ {
|
||||
my $str = shift;
|
||||
return reader::read_str($str);
|
||||
return read_str($str);
|
||||
}
|
||||
|
||||
# eval
|
||||
sub starts_with {
|
||||
my ($ast, $sym) = @_;
|
||||
return @$ast && $ast->[0]->isa('Mal::Symbol') && ${$ast->[0]} eq $sym;
|
||||
my ( $ast, $sym ) = @_;
|
||||
return @{$ast} && $ast->[0]->isa('Mal::Symbol') && ${ $ast->[0] } eq $sym;
|
||||
}
|
||||
|
||||
sub quasiquote_loop {
|
||||
my ($ast) = @_;
|
||||
my $res = Mal::List->new([]);
|
||||
foreach my $elt (reverse @$ast) {
|
||||
if ($elt->isa('Mal::List') and starts_with($elt, 'splice-unquote')) {
|
||||
$res = Mal::List->new([Mal::Symbol->new('concat'), $elt->[1], $res]);
|
||||
} else {
|
||||
$res = Mal::List->new([Mal::Symbol->new('cons'), quasiquote($elt), $res]);
|
||||
my $res = Mal::List->new( [] );
|
||||
foreach my $elt ( reverse @{$ast} ) {
|
||||
if ( $elt->isa('Mal::List') and starts_with( $elt, 'splice-unquote' ) )
|
||||
{
|
||||
$res =
|
||||
Mal::List->new( [ Mal::Symbol->new('concat'), $elt->[1], $res ] );
|
||||
}
|
||||
else {
|
||||
$res = Mal::List->new(
|
||||
[ Mal::Symbol->new('cons'), quasiquote($elt), $res ] );
|
||||
}
|
||||
}
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub quasiquote {
|
||||
my ($ast) = @_;
|
||||
if ($ast->isa('Mal::Vector')) {
|
||||
return Mal::List->new([Mal::Symbol->new('vec'), quasiquote_loop($ast)]);
|
||||
} elsif ($ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol')) {
|
||||
return Mal::List->new([Mal::Symbol->new("quote"), $ast]);
|
||||
} elsif (!$ast->isa('Mal::List')) {
|
||||
return $ast;
|
||||
} elsif (starts_with($ast, 'unquote')) {
|
||||
return $ast->[1];
|
||||
} else {
|
||||
return quasiquote_loop($ast);
|
||||
if ( $ast->isa('Mal::Vector') ) {
|
||||
return Mal::List->new(
|
||||
[ Mal::Symbol->new('vec'), quasiquote_loop($ast) ] );
|
||||
}
|
||||
}
|
||||
|
||||
sub EVAL {
|
||||
my($ast, $env) = @_;
|
||||
|
||||
my $dbgeval = $env->get('DEBUG-EVAL');
|
||||
if ($dbgeval and $dbgeval ne $nil and $dbgeval ne $false) {
|
||||
print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
if ( $ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol') ) {
|
||||
return Mal::List->new( [ Mal::Symbol->new('quote'), $ast ] );
|
||||
}
|
||||
|
||||
if ($ast->isa('Mal::Symbol')) {
|
||||
my $val = $env->get($$ast);
|
||||
die "'$$ast' not found\n" unless $val;
|
||||
return $val;
|
||||
} elsif ($ast->isa('Mal::Vector')) {
|
||||
return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]);
|
||||
} elsif ($ast->isa('Mal::HashMap')) {
|
||||
return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast });
|
||||
} elsif (! $ast->isa('Mal::List')) {
|
||||
return $ast;
|
||||
}
|
||||
|
||||
# apply list
|
||||
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($$sym, EVAL($val, $env));
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($$k, EVAL($v, $let_env));
|
||||
}
|
||||
@_ = ($body, $let_env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('quote') {
|
||||
if ( $ast->isa('Mal::List') ) {
|
||||
if ( starts_with( $ast, 'unquote' ) ) {
|
||||
return $ast->[1];
|
||||
}
|
||||
when ('quasiquote') {
|
||||
@_ = (quasiquote($ast->[1]), $env);
|
||||
goto &EVAL;
|
||||
return quasiquote_loop($ast);
|
||||
}
|
||||
return $ast;
|
||||
}
|
||||
|
||||
my %special_forms = (
|
||||
'def!' => \&special_def,
|
||||
'let*' => \&special_let,
|
||||
|
||||
'do' => \&special_do,
|
||||
'if' => \&special_if,
|
||||
'fn*' => \&special_fn,
|
||||
|
||||
'quasiquote' => \&special_quasiquote,
|
||||
'quote' => \&special_quote,
|
||||
|
||||
'defmacro!' => \&special_defmacro,
|
||||
);
|
||||
|
||||
sub EVAL {
|
||||
my ( $ast, $env ) = @_;
|
||||
|
||||
my $dbgeval = $env->get('DEBUG-EVAL');
|
||||
if ( $dbgeval
|
||||
and not $dbgeval->isa('Mal::Nil')
|
||||
and not $dbgeval->isa('Mal::False') )
|
||||
{
|
||||
print 'EVAL: ', pr_str($ast), "\n" or die $ERRNO;
|
||||
}
|
||||
|
||||
if ( $ast->isa('Mal::Symbol') ) {
|
||||
return $env->get( ${$ast} ) // die "'${$ast}' not found\n";
|
||||
}
|
||||
if ( $ast->isa('Mal::Vector') ) {
|
||||
return Mal::Vector->new( [ map { EVAL( $_, $env ) } @{$ast} ] );
|
||||
}
|
||||
if ( $ast->isa('Mal::HashMap') ) {
|
||||
return Mal::HashMap->new(
|
||||
{ pairmap { $a => EVAL( $b, $env ) } %{$ast} } );
|
||||
}
|
||||
if ( $ast->isa('Mal::List') and @{$ast} ) {
|
||||
my ( $a0, @args ) = @{$ast};
|
||||
if ( $a0->isa('Mal::Symbol') and my $sf = $special_forms{ ${$a0} } ) {
|
||||
@_ = ( $env, @args );
|
||||
goto &{$sf};
|
||||
}
|
||||
when ('defmacro!') {
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($$sym, Mal::Macro->new(EVAL($val, $env)->clone));
|
||||
}
|
||||
when ('do') {
|
||||
my (undef, @todo) = @$ast;
|
||||
my $last = pop @todo;
|
||||
map { EVAL($_, $env) } @todo;
|
||||
@_ = ($last, $env);
|
||||
my $f = EVAL( $a0, $env );
|
||||
if ( $f->isa('Mal::Macro') ) {
|
||||
@_ = ( $f->(@args), $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('if') {
|
||||
my (undef, $if, $then, $else) = @$ast;
|
||||
my $cond = EVAL($if, $env);
|
||||
if ($cond eq $nil || $cond eq $false) {
|
||||
@_ = ($else // $nil, $env);
|
||||
} else {
|
||||
@_ = ($then, $env);
|
||||
}
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('fn*') {
|
||||
my (undef, $params, $body) = @$ast;
|
||||
return Mal::Function->new(sub {
|
||||
#print "running fn*\n";
|
||||
@_ = ($body, Mal::Env->new($env, $params, \@_));
|
||||
goto &EVAL;
|
||||
});
|
||||
}
|
||||
default {
|
||||
my $f = EVAL($a0, $env);
|
||||
my (undef, @args) = @$ast;
|
||||
if ($f->isa('Mal::Macro')) {
|
||||
@_ = (&$f(@args), $env);
|
||||
goto &EVAL;
|
||||
}
|
||||
@_ = map { EVAL($_, $env) } @args;
|
||||
goto &$f;
|
||||
}
|
||||
@_ = map { EVAL( $_, $env ) } @args;
|
||||
goto &{$f};
|
||||
}
|
||||
return $ast;
|
||||
}
|
||||
|
||||
sub special_def {
|
||||
my ( $env, $sym, $val ) = @_;
|
||||
return $env->set( ${$sym}, EVAL( $val, $env ) );
|
||||
}
|
||||
|
||||
sub special_let {
|
||||
my ( $env, $bindings, $body ) = @_;
|
||||
my $let_env = Env->new($env);
|
||||
foreach my $pair ( pairs @{$bindings} ) {
|
||||
my ( $k, $v ) = @{$pair};
|
||||
$let_env->set( ${$k}, EVAL( $v, $let_env ) );
|
||||
}
|
||||
@_ = ( $body, $let_env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_quote {
|
||||
my ( $env, $quoted ) = @_;
|
||||
return $quoted;
|
||||
}
|
||||
|
||||
sub special_quasiquote {
|
||||
my ( $env, $quoted ) = @_;
|
||||
@_ = ( quasiquote($quoted), $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_defmacro {
|
||||
my ( $env, $sym, $val ) = @_;
|
||||
return $env->set( ${$sym}, Mal::Macro->new( EVAL( $val, $env )->clone ) );
|
||||
}
|
||||
|
||||
sub special_do {
|
||||
my ( $env, @todo ) = @_;
|
||||
my $final = pop @todo;
|
||||
for (@todo) {
|
||||
EVAL( $_, $env );
|
||||
}
|
||||
@_ = ( $final, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_if {
|
||||
my ( $env, $if, $then, $else ) = @_;
|
||||
my $cond = EVAL( $if, $env );
|
||||
if ( not $cond->isa('Mal::Nil') and not $cond->isa('Mal::False') ) {
|
||||
@_ = ( $then, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
if ($else) {
|
||||
@_ = ( $else, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
return nil;
|
||||
}
|
||||
|
||||
sub special_fn {
|
||||
my ( $env, $params, $body ) = @_;
|
||||
return Mal::Function->new(
|
||||
sub {
|
||||
@_ = ( $body, Env->new( $env, $params, \@_ ) );
|
||||
goto &EVAL;
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
# print
|
||||
sub PRINT {
|
||||
my $exp = shift;
|
||||
return printer::_pr_str($exp);
|
||||
return pr_str($exp);
|
||||
}
|
||||
|
||||
# repl
|
||||
my $repl_env = Mal::Env->new();
|
||||
my $repl_env = Env->new();
|
||||
|
||||
sub REP {
|
||||
my $str = shift;
|
||||
return PRINT(EVAL(READ($str), $repl_env));
|
||||
return PRINT( EVAL( READ($str), $repl_env ) );
|
||||
}
|
||||
|
||||
# core.pl: defined using perl
|
||||
foreach my $n (keys %core::ns) {
|
||||
$repl_env->set($n, $core::ns{$n});
|
||||
# Command line arguments
|
||||
if ( $ARGV[0] eq '--raw' ) {
|
||||
set_rl_mode('raw');
|
||||
shift @ARGV;
|
||||
}
|
||||
$repl_env->set('eval',
|
||||
Mal::Function->new(sub { EVAL($_[0], $repl_env) }));
|
||||
my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV];
|
||||
$repl_env->set('*ARGV*', Mal::List->new(\@_argv));
|
||||
my $script_file = shift @ARGV;
|
||||
|
||||
# core.pl: defined using perl
|
||||
while ( my ( $k, $v ) = each %NS ) {
|
||||
$repl_env->set( $k, Mal::Function->new($v) );
|
||||
}
|
||||
$repl_env->set( 'eval',
|
||||
Mal::Function->new( sub { EVAL( $_[0], $repl_env ) } ) );
|
||||
$repl_env->set( '*ARGV*',
|
||||
Mal::List->new( [ map { Mal::String->new($_) } @ARGV ] ) );
|
||||
|
||||
# core.mal: defined using the language itself
|
||||
REP(q[(def! not (fn* (a) (if a false true)))]);
|
||||
REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]);
|
||||
REP(q[(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw "odd number of forms to cond")) (cons 'cond (rest (rest xs)))))))]);
|
||||
REP(<<'EOF');
|
||||
(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))
|
||||
EOF
|
||||
REP(<<'EOF');
|
||||
(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)
|
||||
(if (> (count xs) 1) (nth xs 1) (throw "odd number of forms to cond"))
|
||||
(cons 'cond (rest (rest xs)))))))
|
||||
EOF
|
||||
|
||||
if (@ARGV && $ARGV[0] eq "--raw") {
|
||||
set_rl_mode("raw");
|
||||
shift @ARGV;
|
||||
}
|
||||
if (@ARGV) {
|
||||
REP(qq[(load-file "$ARGV[0]")]);
|
||||
if ( defined $script_file ) {
|
||||
REP(qq[(load-file "$script_file")]);
|
||||
exit 0;
|
||||
}
|
||||
while (1) {
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
if (defined(blessed $err) && $err->isa('Mal::BlankException')) {
|
||||
# ignore and continue
|
||||
} else {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
};
|
||||
while ( defined( my $line = mal_readline('user> ') ) ) {
|
||||
eval {
|
||||
print REP($line), "\n" or die $ERRNO;
|
||||
1;
|
||||
} or do {
|
||||
my $err = $EVAL_ERROR;
|
||||
print 'Error: ', $err or die $ERRNO;
|
||||
};
|
||||
}
|
||||
|
||||
@ -1,222 +1,265 @@
|
||||
use strict;
|
||||
use warnings FATAL => "recursion";
|
||||
no if $] >= 5.018, warnings => "experimental::smartmatch";
|
||||
use feature qw(switch);
|
||||
use File::Basename;
|
||||
use lib dirname (__FILE__);
|
||||
#!/usr/bin/perl
|
||||
|
||||
use Data::Dumper;
|
||||
use List::Util qw(pairs pairmap);
|
||||
use strict;
|
||||
use warnings FATAL => 'recursion';
|
||||
use File::Basename 'dirname';
|
||||
use lib dirname(__FILE__);
|
||||
|
||||
use English '-no_match_vars';
|
||||
use List::Util qw(pairs pairmap);
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
use readline qw(mal_readline set_rl_mode);
|
||||
use types qw($nil $true $false);
|
||||
use reader;
|
||||
use printer;
|
||||
use env;
|
||||
use core;
|
||||
use Readline qw(mal_readline set_rl_mode);
|
||||
use Types qw(nil false);
|
||||
use Reader qw(read_str);
|
||||
use Printer qw(pr_str);
|
||||
use Env;
|
||||
use Core qw(%NS);
|
||||
|
||||
# False positives because of TCO.
|
||||
## no critic (Subroutines::RequireArgUnpacking)
|
||||
|
||||
# read
|
||||
sub READ {
|
||||
my $str = shift;
|
||||
return reader::read_str($str);
|
||||
return read_str($str);
|
||||
}
|
||||
|
||||
# eval
|
||||
sub starts_with {
|
||||
my ($ast, $sym) = @_;
|
||||
return @$ast && $ast->[0]->isa('Mal::Symbol') && ${$ast->[0]} eq $sym;
|
||||
my ( $ast, $sym ) = @_;
|
||||
return @{$ast} && $ast->[0]->isa('Mal::Symbol') && ${ $ast->[0] } eq $sym;
|
||||
}
|
||||
|
||||
sub quasiquote_loop {
|
||||
my ($ast) = @_;
|
||||
my $res = Mal::List->new([]);
|
||||
foreach my $elt (reverse @$ast) {
|
||||
if ($elt->isa('Mal::List') and starts_with($elt, 'splice-unquote')) {
|
||||
$res = Mal::List->new([Mal::Symbol->new('concat'), $elt->[1], $res]);
|
||||
} else {
|
||||
$res = Mal::List->new([Mal::Symbol->new('cons'), quasiquote($elt), $res]);
|
||||
my $res = Mal::List->new( [] );
|
||||
foreach my $elt ( reverse @{$ast} ) {
|
||||
if ( $elt->isa('Mal::List') and starts_with( $elt, 'splice-unquote' ) )
|
||||
{
|
||||
$res =
|
||||
Mal::List->new( [ Mal::Symbol->new('concat'), $elt->[1], $res ] );
|
||||
}
|
||||
else {
|
||||
$res = Mal::List->new(
|
||||
[ Mal::Symbol->new('cons'), quasiquote($elt), $res ] );
|
||||
}
|
||||
}
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub quasiquote {
|
||||
my ($ast) = @_;
|
||||
if ($ast->isa('Mal::Vector')) {
|
||||
return Mal::List->new([Mal::Symbol->new('vec'), quasiquote_loop($ast)]);
|
||||
} elsif ($ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol')) {
|
||||
return Mal::List->new([Mal::Symbol->new("quote"), $ast]);
|
||||
} elsif (!$ast->isa('Mal::List')) {
|
||||
return $ast;
|
||||
} elsif (starts_with($ast, 'unquote')) {
|
||||
return $ast->[1];
|
||||
} else {
|
||||
return quasiquote_loop($ast);
|
||||
if ( $ast->isa('Mal::Vector') ) {
|
||||
return Mal::List->new(
|
||||
[ Mal::Symbol->new('vec'), quasiquote_loop($ast) ] );
|
||||
}
|
||||
}
|
||||
|
||||
sub EVAL {
|
||||
my($ast, $env) = @_;
|
||||
|
||||
my $dbgeval = $env->get('DEBUG-EVAL');
|
||||
if ($dbgeval and $dbgeval ne $nil and $dbgeval ne $false) {
|
||||
print "EVAL: " . printer::_pr_str($ast) . "\n";
|
||||
if ( $ast->isa('Mal::HashMap') or $ast->isa('Mal::Symbol') ) {
|
||||
return Mal::List->new( [ Mal::Symbol->new('quote'), $ast ] );
|
||||
}
|
||||
|
||||
if ($ast->isa('Mal::Symbol')) {
|
||||
my $val = $env->get($$ast);
|
||||
die "'$$ast' not found\n" unless $val;
|
||||
return $val;
|
||||
} elsif ($ast->isa('Mal::Vector')) {
|
||||
return ref($ast)->new([ map { EVAL($_, $env) } @$ast ]);
|
||||
} elsif ($ast->isa('Mal::HashMap')) {
|
||||
return Mal::HashMap->new({ pairmap { $a => EVAL($b, $env) } %$ast });
|
||||
} elsif (! $ast->isa('Mal::List')) {
|
||||
return $ast;
|
||||
}
|
||||
|
||||
# apply list
|
||||
|
||||
unless (@$ast) { return $ast; }
|
||||
my ($a0) = @$ast;
|
||||
given ($a0->isa('Mal::Symbol') ? $$a0 : $a0) {
|
||||
when ('def!') {
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($$sym, EVAL($val, $env));
|
||||
}
|
||||
when ('let*') {
|
||||
my (undef, $bindings, $body) = @$ast;
|
||||
my $let_env = Mal::Env->new($env);
|
||||
foreach my $pair (pairs @$bindings) {
|
||||
my ($k, $v) = @$pair;
|
||||
$let_env->set($$k, EVAL($v, $let_env));
|
||||
}
|
||||
@_ = ($body, $let_env);
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('quote') {
|
||||
if ( $ast->isa('Mal::List') ) {
|
||||
if ( starts_with( $ast, 'unquote' ) ) {
|
||||
return $ast->[1];
|
||||
}
|
||||
when ('quasiquote') {
|
||||
@_ = (quasiquote($ast->[1]), $env);
|
||||
goto &EVAL;
|
||||
return quasiquote_loop($ast);
|
||||
}
|
||||
return $ast;
|
||||
}
|
||||
|
||||
my %special_forms = (
|
||||
'def!' => \&special_def,
|
||||
'let*' => \&special_let,
|
||||
|
||||
'do' => \&special_do,
|
||||
'if' => \&special_if,
|
||||
'fn*' => \&special_fn,
|
||||
|
||||
'quasiquote' => \&special_quasiquote,
|
||||
'quote' => \&special_quote,
|
||||
|
||||
'defmacro!' => \&special_defmacro,
|
||||
|
||||
'try*' => \&special_try,
|
||||
);
|
||||
|
||||
sub EVAL {
|
||||
my ( $ast, $env ) = @_;
|
||||
|
||||
my $dbgeval = $env->get('DEBUG-EVAL');
|
||||
if ( $dbgeval
|
||||
and not $dbgeval->isa('Mal::Nil')
|
||||
and not $dbgeval->isa('Mal::False') )
|
||||
{
|
||||
print 'EVAL: ', pr_str($ast), "\n" or die $ERRNO;
|
||||
}
|
||||
|
||||
if ( $ast->isa('Mal::Symbol') ) {
|
||||
return $env->get( ${$ast} ) // die "'${$ast}' not found\n";
|
||||
}
|
||||
if ( $ast->isa('Mal::Vector') ) {
|
||||
return Mal::Vector->new( [ map { EVAL( $_, $env ) } @{$ast} ] );
|
||||
}
|
||||
if ( $ast->isa('Mal::HashMap') ) {
|
||||
return Mal::HashMap->new(
|
||||
{ pairmap { $a => EVAL( $b, $env ) } %{$ast} } );
|
||||
}
|
||||
if ( $ast->isa('Mal::List') and @{$ast} ) {
|
||||
my ( $a0, @args ) = @{$ast};
|
||||
if ( $a0->isa('Mal::Symbol') and my $sf = $special_forms{ ${$a0} } ) {
|
||||
@_ = ( $env, @args );
|
||||
goto &{$sf};
|
||||
}
|
||||
when ('defmacro!') {
|
||||
my (undef, $sym, $val) = @$ast;
|
||||
return $env->set($$sym, Mal::Macro->new(EVAL($val, $env)->clone));
|
||||
}
|
||||
when ('try*') {
|
||||
my (undef, $try, $catch) = @$ast;
|
||||
local $@;
|
||||
my $ret = eval { EVAL($try, $env) };
|
||||
return $ret unless $@;
|
||||
if ($catch && ${$catch->[0]} eq 'catch*') {
|
||||
my (undef, $binding, $body) = @$catch;
|
||||
my $exc;
|
||||
if (defined(blessed $@) && $@->isa('Mal::Type')) {
|
||||
$exc = $@;
|
||||
} else {
|
||||
chomp(my $msg = $@);
|
||||
$exc = Mal::String->new($msg);
|
||||
}
|
||||
my $catch_env = Mal::Env->new($env, [$binding], [$exc]);
|
||||
@_ = ($body, $catch_env);
|
||||
goto &EVAL;
|
||||
} else {
|
||||
die $@;
|
||||
}
|
||||
}
|
||||
when ('do') {
|
||||
my (undef, @todo) = @$ast;
|
||||
my $last = pop @todo;
|
||||
map { EVAL($_, $env) } @todo;
|
||||
@_ = ($last, $env);
|
||||
my $f = EVAL( $a0, $env );
|
||||
if ( $f->isa('Mal::Macro') ) {
|
||||
@_ = ( $f->(@args), $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('if') {
|
||||
my (undef, $if, $then, $else) = @$ast;
|
||||
my $cond = EVAL($if, $env);
|
||||
if ($cond eq $nil || $cond eq $false) {
|
||||
@_ = ($else // $nil, $env);
|
||||
} else {
|
||||
@_ = ($then, $env);
|
||||
}
|
||||
goto &EVAL;
|
||||
}
|
||||
when ('fn*') {
|
||||
my (undef, $params, $body) = @$ast;
|
||||
return Mal::Function->new(sub {
|
||||
#print "running fn*\n";
|
||||
@_ = ($body, Mal::Env->new($env, $params, \@_));
|
||||
goto &EVAL;
|
||||
});
|
||||
}
|
||||
default {
|
||||
my $f = EVAL($a0, $env);
|
||||
my (undef, @args) = @$ast;
|
||||
if ($f->isa('Mal::Macro')) {
|
||||
@_ = (&$f(@args), $env);
|
||||
goto &EVAL;
|
||||
}
|
||||
@_ = map { EVAL($_, $env) } @args;
|
||||
goto &$f;
|
||||
}
|
||||
@_ = map { EVAL( $_, $env ) } @args;
|
||||
goto &{$f};
|
||||
}
|
||||
return $ast;
|
||||
}
|
||||
|
||||
sub special_def {
|
||||
my ( $env, $sym, $val ) = @_;
|
||||
return $env->set( ${$sym}, EVAL( $val, $env ) );
|
||||
}
|
||||
|
||||
sub special_let {
|
||||
my ( $env, $bindings, $body ) = @_;
|
||||
my $let_env = Env->new($env);
|
||||
foreach my $pair ( pairs @{$bindings} ) {
|
||||
my ( $k, $v ) = @{$pair};
|
||||
$let_env->set( ${$k}, EVAL( $v, $let_env ) );
|
||||
}
|
||||
@_ = ( $body, $let_env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_quote {
|
||||
my ( $env, $quoted ) = @_;
|
||||
return $quoted;
|
||||
}
|
||||
|
||||
sub special_quasiquote {
|
||||
my ( $env, $quoted ) = @_;
|
||||
@_ = ( quasiquote($quoted), $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_defmacro {
|
||||
my ( $env, $sym, $val ) = @_;
|
||||
return $env->set( ${$sym}, Mal::Macro->new( EVAL( $val, $env )->clone ) );
|
||||
}
|
||||
|
||||
sub special_try {
|
||||
my ( $env, $try, $catch ) = @_;
|
||||
if ($catch) {
|
||||
my ( undef, $binding, $body ) = @{$catch};
|
||||
if ( my $ret = eval { EVAL( $try, $env ) } ) {
|
||||
return $ret;
|
||||
}
|
||||
my $exc = $EVAL_ERROR;
|
||||
if ( not blessed($exc) or not $exc->isa('Mal::Type') ) {
|
||||
chomp $exc;
|
||||
$exc = Mal::String->new($exc);
|
||||
}
|
||||
my $catch_env = Env->new( $env, [$binding], [$exc] );
|
||||
@_ = ( $body, $catch_env );
|
||||
goto &EVAL;
|
||||
}
|
||||
@_ = ( $try, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_do {
|
||||
my ( $env, @todo ) = @_;
|
||||
my $final = pop @todo;
|
||||
for (@todo) {
|
||||
EVAL( $_, $env );
|
||||
}
|
||||
@_ = ( $final, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
|
||||
sub special_if {
|
||||
my ( $env, $if, $then, $else ) = @_;
|
||||
my $cond = EVAL( $if, $env );
|
||||
if ( not $cond->isa('Mal::Nil') and not $cond->isa('Mal::False') ) {
|
||||
@_ = ( $then, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
if ($else) {
|
||||
@_ = ( $else, $env );
|
||||
goto &EVAL;
|
||||
}
|
||||
return nil;
|
||||
}
|
||||
|
||||
sub special_fn {
|
||||
my ( $env, $params, $body ) = @_;
|
||||
return Mal::Function->new(
|
||||
sub {
|
||||
@_ = ( $body, Env->new( $env, $params, \@_ ) );
|
||||
goto &EVAL;
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
# print
|
||||
sub PRINT {
|
||||
my $exp = shift;
|
||||
return printer::_pr_str($exp);
|
||||
return pr_str($exp);
|
||||
}
|
||||
|
||||
# repl
|
||||
my $repl_env = Mal::Env->new();
|
||||
my $repl_env = Env->new();
|
||||
|
||||
sub REP {
|
||||
my $str = shift;
|
||||
return PRINT(EVAL(READ($str), $repl_env));
|
||||
return PRINT( EVAL( READ($str), $repl_env ) );
|
||||
}
|
||||
|
||||
# core.pl: defined using perl
|
||||
foreach my $n (keys %core::ns) {
|
||||
$repl_env->set($n, $core::ns{$n});
|
||||
# Command line arguments
|
||||
if ( $ARGV[0] eq '--raw' ) {
|
||||
set_rl_mode('raw');
|
||||
shift @ARGV;
|
||||
}
|
||||
$repl_env->set('eval',
|
||||
Mal::Function->new(sub { EVAL($_[0], $repl_env) }));
|
||||
my @_argv = map {Mal::String->new($_)} @ARGV[1..$#ARGV];
|
||||
$repl_env->set('*ARGV*', Mal::List->new(\@_argv));
|
||||
my $script_file = shift @ARGV;
|
||||
|
||||
# core.pl: defined using perl
|
||||
while ( my ( $k, $v ) = each %NS ) {
|
||||
$repl_env->set( $k, Mal::Function->new($v) );
|
||||
}
|
||||
$repl_env->set( 'eval',
|
||||
Mal::Function->new( sub { EVAL( $_[0], $repl_env ) } ) );
|
||||
$repl_env->set( '*ARGV*',
|
||||
Mal::List->new( [ map { Mal::String->new($_) } @ARGV ] ) );
|
||||
|
||||
# core.mal: defined using the language itself
|
||||
REP(q[(def! not (fn* (a) (if a false true)))]);
|
||||
REP(q[(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))]);
|
||||
REP(q[(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw "odd number of forms to cond")) (cons 'cond (rest (rest xs)))))))]);
|
||||
REP(<<'EOF');
|
||||
(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))
|
||||
EOF
|
||||
REP(<<'EOF');
|
||||
(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)
|
||||
(if (> (count xs) 1) (nth xs 1) (throw "odd number of forms to cond"))
|
||||
(cons 'cond (rest (rest xs)))))))
|
||||
EOF
|
||||
|
||||
if (@ARGV && $ARGV[0] eq "--raw") {
|
||||
set_rl_mode("raw");
|
||||
shift @ARGV;
|
||||
}
|
||||
if (@ARGV) {
|
||||
REP(qq[(load-file "$ARGV[0]")]);
|
||||
if ( defined $script_file ) {
|
||||
REP(qq[(load-file "$script_file")]);
|
||||
exit 0;
|
||||
}
|
||||
while (1) {
|
||||
my $line = mal_readline("user> ");
|
||||
if (! defined $line) { last; }
|
||||
do {
|
||||
local $@;
|
||||
my $ret;
|
||||
eval {
|
||||
print(REP($line), "\n");
|
||||
1;
|
||||
} or do {
|
||||
my $err = $@;
|
||||
if (defined(blessed $err) && $err->isa('Mal::BlankException')) {
|
||||
# ignore and continue
|
||||
} elsif (defined(blessed $err) && $err->isa('Mal::Type')) {
|
||||
print "Error: ".printer::_pr_str($err)."\n";
|
||||
} else {
|
||||
chomp $err;
|
||||
print "Error: $err\n";
|
||||
}
|
||||
};
|
||||
while ( defined( my $line = mal_readline('user> ') ) ) {
|
||||
eval {
|
||||
print REP($line), "\n" or die $ERRNO;
|
||||
1;
|
||||
} or do {
|
||||
my $err = $EVAL_ERROR;
|
||||
if ( defined blessed($err) and $err->isa('Mal::Type') ) {
|
||||
$err = pr_str($err) . "\n";
|
||||
}
|
||||
print 'Error: ', $err or die $ERRNO;
|
||||
};
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user