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

[clkao at bestpractical.com]

Author: clkao
Date: Sat Jan 17 08:02:07 2009
New Revision: 17802

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

Log:
- pacakge support.
- implement Native.Invoke and Str.Eq.


Modified: Lorzy/trunk/lib/Lorzy/Evaluator.pm
==============================================================================
--- Lorzy/trunk/lib/Lorzy/Evaluator.pm	(original)
+++ Lorzy/trunk/lib/Lorzy/Evaluator.pm	Sat Jan 17 08:02:07 2009
@@ -5,6 +5,7 @@
 use Lorzy::EvaluatorResult;
 use Lorzy::Expression;
 use Params::Validate qw/validate validate_pos HASHREF/;
+use UNIVERSAL::require;
 
 has result => (
     is      => 'ro',
@@ -136,6 +137,20 @@
     return \%signatures;
 }
 
+sub load_package {
+    my ($self, $package) = @_;
+    my $pkg = "Lorzy::Package::".$package;
+    $pkg->require or die $!;
+    while (my ($name, $def) = each %{$pkg->functions}) {
+        my $func = $def->{native}
+            ? Lorzy::Lambda::Native->new( body => $def->{native},
+                                          signature => $def->{signature} )
+            : Lorzy::Lambda->new( progn => $def->{ops},
+                                  signature => $def->{signature} );
+        $self->set_global_symbol($package.'.'.$name => $func);
+    }
+}
+
 sub _enumerate_core_expressions {
     my $self = shift;
     return Lorzy::Expression->expression_types;

Added: Lorzy/trunk/lib/Lorzy/Package/Native.pm
==============================================================================
--- (empty file)
+++ Lorzy/trunk/lib/Lorzy/Package/Native.pm	Sat Jan 17 08:02:07 2009
@@ -0,0 +1,20 @@
+package Lorzy::Package::Native;
+use base 'Lorzy::Package';
+
+__PACKAGE__->defun( 'Invoke',
+    signature => {
+        'obj' => Lorzy::FunctionArgument->new( name => 'obj'),
+        'method' => Lorzy::FunctionArgument->new( name => 'method', type => 'Str' ),
+        'args' => Lorzy::FunctionArgument->new( name => 'args' ),
+        },
+    native => sub {
+        my $args = 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 );
+    },
+);
+
+1;

Added: Lorzy/trunk/lib/Lorzy/Package/Str.pm
==============================================================================
--- (empty file)
+++ Lorzy/trunk/lib/Lorzy/Package/Str.pm	Sat Jan 17 08:02:07 2009
@@ -0,0 +1,15 @@
+package Lorzy::Package::Str;
+use base 'Lorzy::Package';
+
+__PACKAGE__->defun( 'Eq',
+    signature => {
+        'arg1' => Lorzy::FunctionArgument->new( name => 'arg1', type => 'Str'),
+        'arg2' => Lorzy::FunctionArgument->new( name => 'arg2', type => 'Str' )
+        },
+    native => sub {
+        my $args = shift;
+        return ($args->{arg1} eq $args->{arg2});
+    },
+);
+
+1;

Modified: Lorzy/trunk/t/roundtrip.t
==============================================================================
--- Lorzy/trunk/t/roundtrip.t	(original)
+++ Lorzy/trunk/t/roundtrip.t	Sat Jan 17 08:02:07 2009
@@ -12,32 +12,14 @@
 my $builder = Lorzy::Builder->new();
 my $eval = Lorzy::Evaluator->new();
 
-my $invoke_native = Lorzy::Lambda::Native->new(
-    body => sub {
-        my $args = 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 );
-    },
-
-    signature => {
-        'obj' => Lorzy::FunctionArgument->new( name => 'obj'),
-        'method' => Lorzy::FunctionArgument->new( name => 'method', type => 'Str' ),
-        'args' => Lorzy::FunctionArgument->new( name => 'args' ),
-        }
-
-);
-
-$eval->set_global_symbol( 'invoke!' => $invoke_native );
+$eval->load_package('Native');
 
 my $script = $builder->defun(
                              ops => [
                                      { name => 'ProgN',
                                        args => {
                                                 nodes => [
-                                                          { name => 'invoke!', args => 
+                                                          { name => 'Native.Invoke', args => 
                                                             { obj => { name => 'Symbol', args => { symbol => 'something' } },
                                                               method => 'hello',
                                                               args => { name => 'List', nodes => [ 'orz' ] },