added chunk functions

phaylon · Jan 9, 2009 · cea2532 · cea2532
1 parent f1b5664
commit cea2532
Show file tree

Hide file tree

Showing 3 changed files with 26 additions and 2 deletions.
diff --git a/lib/Script/SXC/Library/Core.pm b/lib/Script/SXC/Library/Core.pm
@@ -18,7 +18,8 @@ CLASS->add_delegated_items({
     'Script::SXC::Library::Core::Conditionals'  
         => [qw( if unless )],
 
-    'Script::SXC::Library::Core::Functions'     => [qw( lambda λ )],
+    'Script::SXC::Library::Core::Functions'     
+        => [qw( lambda λ chunk λ… )],
 
     'Script::SXC::Library::Core::Let'           => [qw( let let* let-rec )],
 

diff --git a/lib/Script/SXC/Library/Core/Functions.pm b/lib/Script/SXC/Library/Core/Functions.pm
@@ -62,4 +62,15 @@ TODO fix up documentation
         for qw( lambda λ );
 }
 
+for my $chunk_name (qw( chunk λ… )) {
+    CLASS->add_inliner($chunk_name, via => method (Object :$compiler!, Object :$env!, Str :$name!, ArrayRef :$exprs!, :$error_cb!, :$symbol) {
+        CLASS->check_arg_count($error_cb, $name, $exprs, min => 1);
+        return $symbol->new_item_with_source(List => { contents => [
+            $symbol->new_item_with_source(Builtin => { value => 'lambda' }),
+            $symbol->new_item_with_source(List    => { contents => [] }),
+            @$exprs,
+        ]})->compile($compiler, $env);
+    });
+}
+
 1;
diff --git a/t/lib/Script/SXC/Test/Library/Core/Lambdas.pm b/t/lib/Script/SXC/Test/Library/Core/Lambdas.pm
@@ -9,7 +9,7 @@ use Data::Dump qw( dump );
 sub T200_lambdas: Tests {
     my $self = self;
 
-    # simple without scoping tests
+    # simple without scoping
     {   my $lambda = self->run('(lambda () 23)');
         is ref($lambda), 'CODE', 'simple lambda returned code reference';
         is $lambda->(), 23, 'execution of lambda returned evaluated body expression';
@@ -120,4 +120,16 @@ sub T200_lambdas: Tests {
     }
 }
 
+sub T800_chunks: Tests {
+    my $self = self;
+
+    for my $name (qw( chunk λ… )) {
+        is ref(self->run("($name 23)")), 'CODE', "$name builds successful code reference";
+        is self->run("(($name 23))"), 23, "$name returns evaluated body expression on call";
+        throws_ok { $self->run("($name)") } 'Script::SXC::Exception', "$name without body throws exception";
+        like $@, qr/$name/, qq(error message contains "$name");
+        like $@, qr/missing/i, 'error message contains "missing"';
+    }
+}
+
 1;