[Bps-public-commit] r18831 - in Lorzy/trunk: lib/Lorzy/Lambda lib/Lorzy/Package t

[clkao at bestpractical.com]

Author: clkao
Date: Wed Mar 18 10:14:00 2009
New Revision: 18831

Modified:
   Lorzy/trunk/lib/Lorzy/Evaluator.pm
   Lorzy/trunk/lib/Lorzy/Lambda/Native.pm
   Lorzy/trunk/lib/Lorzy/Package/Native.pm
   Lorzy/trunk/t/roundtrip.t

Log:
implement Native.Apply.


Modified: Lorzy/trunk/lib/Lorzy/Evaluator.pm
==============================================================================
--- Lorzy/trunk/lib/Lorzy/Evaluator.pm	(original)
+++ Lorzy/trunk/lib/Lorzy/Evaluator.pm	Wed Mar 18 10:14:00 2009
@@ -188,7 +188,7 @@
 sub evaluated_result {
     my ($self, $exp) = @_;
 
-    ref($exp) && $exp->can('meta') && $exp->meta->does_role('Lorzy::Evaluatable')
+    ref($exp) && UNIVERSAL::can($exp, 'meta') && $exp->meta->does_role('Lorzy::Evaluatable')
          ? $exp->evaluate($self)
          : $exp; # XXX: figure out evaluation order here
 

Modified: Lorzy/trunk/lib/Lorzy/Lambda/Native.pm
==============================================================================
--- Lorzy/trunk/lib/Lorzy/Lambda/Native.pm	(original)
+++ Lorzy/trunk/lib/Lorzy/Lambda/Native.pm	Wed Mar 18 10:14:00 2009
@@ -12,7 +12,7 @@
     $self->validate_args_or_die($args);
     my %args = map { $_ => $evaluator->evaluated_result($args->{$_}) }
         keys %$args;
-    my $r = $self->body->(\%args);
+    my $r = $self->body->(\%args, $evaluator);
     return $r;
 }
 

Modified: Lorzy/trunk/lib/Lorzy/Package/Native.pm
==============================================================================
--- Lorzy/trunk/lib/Lorzy/Package/Native.pm	(original)
+++ Lorzy/trunk/lib/Lorzy/Package/Native.pm	Wed Mar 18 10:14:00 2009
@@ -1,5 +1,6 @@
 package Lorzy::Package::Native;
 use base 'Lorzy::Package';
+use strict;
 
 __PACKAGE__->defun( 'Invoke',
     signature => {
@@ -9,11 +10,27 @@
         },
     native => sub {
         my $args = shift;
+        my $eval = shift;
         my $method = $args->{method};
         die "Invalid 'args' $args->{args}" unless ref($args->{args}) eq 'Lorzy::EvaluatorResult::RunTime';
         my $nodes = ${$args->{args}};
 
-        $args->{obj}->$method( @$nodes );
+        $args->{obj}->$method( map { $eval->evaluated_result($_) } @$nodes );
+    },
+);
+
+__PACKAGE__->defun( 'Apply',
+    signature => {
+        'code' => Lorzy::FunctionArgument->new( name => 'code'),
+        'args' => Lorzy::FunctionArgument->new( name => 'args' ),
+        },
+    native => sub {
+        my $args = shift;
+        my $eval = shift;
+        die "Invalid 'args' $args->{args}" unless ref($args->{args}) eq 'Lorzy::EvaluatorResult::RunTime';
+        my $nodes = ${$args->{args}};
+
+        $args->{code}->( map { $eval->evaluated_result($_) }@$nodes );
     },
 );
 

Modified: Lorzy/trunk/t/roundtrip.t
==============================================================================
--- Lorzy/trunk/t/roundtrip.t	(original)
+++ Lorzy/trunk/t/roundtrip.t	Wed Mar 18 10:14:00 2009
@@ -22,7 +22,7 @@
                                                           { name => 'Native.Invoke', args => 
                                                             { obj => { name => 'Symbol', args => { symbol => 'something' } },
                                                               method => 'hello',
-                                                              args => { name => 'List', nodes => [ 'orz' ] },
+                                                              args => { name => 'List', args => { nodes => [ 'orz' ] } },
                                                                                      } },
                          ],
                                                } } ],
@@ -43,7 +43,7 @@
                                                 nodes => [
                                                           { name => 'Native.Apply', args => 
                                                             { code => { name => 'Symbol', args => { symbol => 'code' } },
-                                                              args => { name => 'List', nodes => [ 'orz' ] },
+                                                              args => { name => 'List', args => { nodes => [ 'orz', 'orz2' ] } },
                                                                                      } },
                          ],
                                                } } ],
@@ -61,7 +61,7 @@
     $ret = $eval->apply_script( $script2, { 'code' => $code } );
 };
 ok($called);
-is($ret, 'roundtrip: orz');
+is($ret, 'roundtrip: orz,orz2');
 
 package TestClass;