Implement block mechanism and macros block, return and return-from

lib/Minilisp.pm

@@ -531,6 +531,41 @@ sub parser_call {
   };
 }
 
+sub create_block {
+  my $blockname = shift;
+  my $inner = shift;
+
+  return sub {
+    my $ctx = shift;
+
+    my $result;
+    eval {
+      $result = $inner->($ctx);
+    };
+
+    if ($@)
+      {
+        if (ref($@) eq "BLOCK::$blockname")
+          {
+            return $@->{retval};
+          }
+        else
+          {
+            die $@;
+          }
+      }
+
+    return $result;
+  };
+}
+
+sub return_from_block {
+  my $blockname = shift;
+  my $retval = shift;
+
+  die bless({ retval => $retval }, "BLOCK::$blockname");
+}
+
 sub gen_macro_let {
   my $incremental = shift;
   return sub {
@@ -898,6 +933,50 @@ sub macro_do {
 }
 $macros{do} = \&macro_do;
 
+sub macro_block {
+  my $ts = shift;
+
+  my $blockname = slurp_token($ts, IDENT, "Expected identifier after block")->{value};
+
+  my $inner = macro_progn($ts);
+
+  return create_block($blockname, $inner);
+}
+$macros{block} = \&macro_block;
+
+
+sub macro_return_common {
+  my $ts = shift;
+  my $blockname = shift;
+
+  my $return_expr = sub { undef };
+
+  $return_expr = parser_expr($ts) unless peek_token($ts, RPAREN);
+
+  return sub {
+    my $ctx = shift;
+
+    my $retval = $return_expr->($ctx);
+
+    return_from_block($blockname, $retval);
+  }
+}
+
+sub macro_return_from {
+  my $ts = shift;
+
+  my $blockname = slurp_token($ts, IDENT, "Expected identifier after block")->{value};
+
+  return macro_return_common($ts, $blockname);
+}
+$macros{'return-from'} = \&macro_return_from;
+
+sub macro_return {
+  my $ts = shift;
+  return macro_return_common($ts, "nil");
+}
+$macros{'return'} = \&macro_return;
+
 sub compile {
   my ($term) = @_;
   my @tokens = tokenize($term);