CljPerl
view release on metacpan or search on metacpan
lib/CljPerl/Evaler.pm view on Meta::CPAN
$reader->ast()->each(sub {$res = $self->_eval($_[0])});
return $res;
}
our $builtin_funcs = {
"eval"=>1,
"syntax"=>1,
"catch"=>1,
"exception-label"=>1,
"exception-message"=>1,
"throw"=>1,
"def"=>1,
"set!"=>1,
"let"=>1,
"fn"=>1,
"defmacro"=>1,
"gen-sym"=>1,
"list"=>1,
"car"=>1,
"cdr"=>1,
"cons"=>1,
"if"=>1,
"while"=>1,
"begin"=>1,
"length"=>1,
"reverse"=>1,
"object-id"=>1,
"type"=>1,
"perlobj-type"=>1,
"meta"=>1,
"apply"=>1,
"append"=>1,
"keys"=>1,
"namespace-begin"=>1,
"namespace-end"=>1,
"perl->clj"=>1,
"clj->string"=>1,
"!"=>1,
"not"=>1,
"+"=>1,
"-"=>1,
"*"=>1,
"/"=>1,
"%"=>1,
"=="=>1,
"!="=>1,
">"=>1,
">="=>1,
"<"=>1,
"<="=>1,
"."=>1,
"->"=>1,
"eq"=>1,
"ne"=>1,
"and"=>1,
"or"=>1,
"equal"=>1,
"require"=>1,
"read"=>1,
"println"=>1,
"coro"=>1,
"coro-suspend"=>1,
"coro-sleep"=>1,
"coro-yield"=>1,
"coro-resume"=>1,
"coro-wake"=>1,
"coro-join"=>1,
"coro-current"=>1,
"coro-main"=>1,
"xml-name"=>1,
"trace-vars"=>1};
our $empty_list = CljPerl::Seq->new("list");
our $true = CljPerl::Atom->new("bool", "true");
our $false = CljPerl::Atom->new("bool", "false");
our $nil = CljPerl::Atom->new("nil", "nil");
sub bind {
my $self = shift;
my $ast = shift;
my $class = $ast->class();
my $type = $ast->type();
my $value = $ast->value();
if($type eq "symbol" and $value eq "true") {
return $true;
} elsif($type eq "symbol" and $value eq "false") {
return $false;
} elsif($type eq "symbol" and $value eq "nil") {
return $nil;
} elsif($type eq "accessor") {
return CljPerl::Atom->new("accessor", $self->bind($value));
} elsif($type eq "sender") {
return CljPerl::Atom->new("sender", $self->bind($value));
} elsif($type eq "syntaxquotation" or $type eq "quotation") {
$self->{syntaxquotation_scope} += 1 if $type eq "syntaxquotation";
$self->{quotation_scope} += 1 if $type eq "quotation";
my $r = $self->bind($value);
$self->{syntaxquotation_scope} -= 1 if $type eq "syntaxquotation";
$self->{quotation_scope} -= 1 if $type eq "quotation";
return $r;
} elsif(($type eq "symbol" and $self->{syntaxquotation_scope} == 0
and $self->{quotation_scope} == 0) or
($type eq "dequotation" and $self->{syntaxquotation_scope} > 0)) {
$ast->error("dequotation should be in syntax quotation scope")
if ($type eq "dequotation" and $self->{syntaxquotation_scope} == 0);
my $name = $value;
if($type eq "dequotation" and $value =~ /^@(\S+)$/) {
$name = $1;
}
return $ast if exists $builtin_funcs->{$name} or $name =~ /^(\.|->)\S+$/;
my $var = $self->var($name);
$ast->error("unbound symbol") if !defined $var;
return $var->value();
} elsif($type eq "symbol"
and $self->{quotation_scope} > 0) {
my $q = CljPerl::Atom->new("quotation", $value);
return $q;
} elsif($class eq "Seq") {
return $empty_list if $type eq "list" and $ast->size() == 0;
my $list = CljPerl::Seq->new("list");
$list->type($type);
foreach my $i (@{$value}) {
if($i->type() eq "dequotation" and $i->value() =~ /^@/){
my $dl = $self->bind($i);
$i->error("~@ should be given a list but got " . $dl->type()) if $dl->type() ne "list";
foreach my $di (@{$dl->value()}){
$list->append($di);
};
} else {
lib/CljPerl/Evaler.pm view on Meta::CPAN
$ast->error("no meta data in " . CljPerl::Printer::to_string($v)) if !defined $m;
return $m;
} elsif($fn eq "clj->string") {
$ast->error("clj->string expects 1 argument") if $size != 2;
my $v = $self->_eval($ast->second());
return CljPerl::Atom->new("string", CljPerl::Printer::to_string($v));
# (.namespace function args...)
} elsif($fn =~ /^(\.|->)(\S*)$/) {
my $blessed = $1;
my $ns = $2;
$ast->error(". expects > 1 arguments") if $size < 2;
$ast->error(". expects a symbol or keyword or stirng as the first argument but got " . $ast->second()->type())
if ($ast->second()->type() ne "symbol"
and $ast->second()->type() ne "keyword"
and $ast->second()->type() ne "string");
my $perl_func = $ast->second()->value();
if($perl_func eq "require") {
$ast->error(". require expects 1 argument") if $size != 3;
my $m = $ast->third();
if($m->type() eq "keyword" or $m->type() eq "symbol") {
} elsif($m->type() eq "string") {
$m = $self->_eval($ast->third());
} else {
$ast->error(". require expects a string but got " . $m->type());
};
my $mn = $m->value();
$mn =~ s/::/\//g;
foreach my $ext ("", ".pm") {
if(-f $mn . $ext) {
require $mn . $ext;
return $true;
};
foreach my $p (@INC) {
if(-f "$p/$mn$ext") {
require "$p/$mn$ext";
return $true;
};
}
}
$ast->error("cannot find $mn");
} else {
$ns = "CljPerl" if ! defined $ns or $ns eq "";
my $meta = undef;
$meta = $self->_eval($ast->third()) if defined $ast->third() and $ast->third()->type() eq "meta";
$perl_func = $ns . "::" . $perl_func;
my @rest = $ast->slice((defined $meta ? 3 : 2) .. $size-1);
unshift @rest, CljPerl::Atom->new("string", $ns) if $blessed eq "->";
return $self->perlfunc_call($perl_func, $meta, \@rest);
}
# (perl->clj o)
} elsif($fn eq "perl->clj") {
$ast->error("perl->clj expects 1 argument") if $size != 2;
my $o = $self->_eval($ast->second());
$ast->error("perl->clj expects perlobject as argument but got " . $o->type()) if $o->type() ne "perlobject";
return &perl2clj($o->value());
# (println obj)
} elsif($fn eq "println") {
$ast->error("println expects 1 argument") if $size != 2;
print CljPerl::Printer::to_string($self->_eval($ast->second())) . "\n";
return $nil;
} elsif($fn eq "coro") {
$ast->error("coro expects 1 argument") if $size != 2;
my $b = $self->_eval($ast->second());
$ast->error("core expects a function as argument but got " . $b->type()) if $b->type() ne "function";
my $coro = new Coro sub {
my $evaler = CljPerl::Evaler->new();
my $fc = CljPerl::Seq->new("list");
$fc->append($b);
$evaler->_eval($fc);
};
$coro->ready();
return CljPerl::Atom->new("coroutine", $coro);
} elsif($fn eq "coro-suspend") {
$ast->error("coro-suspend expects 1 argument") if $size != 2;
my $coro = $self->_eval($ast->second());
$ast->error("coro-suspend expects a coroutine as argument but got " . $coro->type()) if $coro->type() ne "coroutine";
$coro->value()->suspend();
return $coro;
} elsif($fn eq "coro-sleep") {
$ast->error("coro-sleep expects 0 argument") if $size != 1;
$Coro::current->suspend();
cede;
return CljPerl::Atom->new("coroutine", $Coro::current);
} elsif($fn eq "coro-yield") {
$ast->error("coro-yield expects 0 argument") if $size != 1;
cede;
return CljPerl::Atom->new("coroutine", $Coro::current);
} elsif($fn eq "coro-resume") {
$ast->error("coro-resume expects 1 argument") if $size != 2;
my $coro = $self->_eval($ast->second());
$ast->error("coro-resume expects a coroutine as argument but got " . $coro->type()) if $coro->type() ne "coroutine";
$coro->value()->resume();
$coro->value()->cede_to();
return $coro;
} elsif($fn eq "coro-wake") {
$ast->error("coro-wake expects 1 argument") if $size != 2;
my $coro = $self->_eval($ast->second());
$ast->error("coro-wake expects a coroutine as argument but got " . $coro->type()) if $coro->type() ne "coroutine";
$coro->value()->resume();
return $coro;
} elsif($fn eq "join-coro") {
$ast->error("join-coro expects 1 argument") if $size != 2;
my $coro = $self->_eval($ast->second());
$ast->error("join-coro expects a coroutine as argument but got " . $coro->type()) if $coro->type() ne "coroutine";
$coro->value()->join();
return $coro;
} elsif($fn eq "coro-current") {
$ast->error("coro-current expects 0 argument") if $size != 1;
return CljPerl::Atom->new("coroutine", $Coro::current);
} elsif($fn eq "coro-main") {
$ast->error("coro-main expects 0 argument") if $size != 1;
return CljPerl::Atom->new("coroutine", $Coro::main);
} elsif($fn eq "trace-vars") {
$ast->error("trace-vars expects 0 argument") if $size != 1;
$self->trace_vars();
return $nil;
};
return $ast;
}
sub perlfunc_call {
my $self = shift;
my $perl_func = shift;
my $meta = shift;
my $rargs = shift;
my $ret_type = "scalar";
my @fargtypes = ();
if(defined $meta) {
if(exists $meta->value()->{"return"}) {
my $rt = $meta->value()->{"return"};
$ast->error("return expects a string or keyword but got " . $rt->type())
if $rt->type() ne "string"
and $rt->type() ne "keyword";
$ret_type = $rt->value();
};
if(exists $meta->value()->{"arguments"}) {
my $ats = $meta->value()->{"arguments"};
$ast->error("arguments expect a vector but got " . $ats->type()) if $ats->type() ne "vector";
foreach my $arg (@{$ats->value()}) {
$ast->error("arguments expect a vector of string or keyword but got " . $arg->type())
if $arg->type() ne "string"
and $arg->type() ne "keyword";
push @fargtypes, $arg->value();
};
};
};
my @args = ();
my $i = 0;
foreach my $arg (@{$rargs}) {
my $pobj = $self->clj2perl($self->_eval($arg));
if($i < scalar @fargtypes) {
my $ft = $fargtypes[$i];
if($ft eq "scalar") {
push @args, $pobj;
} elsif($ft eq "array") {
push @args, @{$pobj};
} elsif($ft eq "hash") {
push @args, %{$pobj};
} elsif($ft eq "ref") {
push @args, \$pobj;
} else {
push @args, $pobj;
};
} else {
if(ref($pobj) eq "ARRAY") {
push @args, @{$pobj};
} elsif(ref($pobj) eq "HASH") {
push @args, %{$pobj};
} else {
push @args, $pobj;
};
( run in 2.423 seconds using v1.01-cache-2.11-cpan-2398b32b56e )