From a355528492085f7668dda99648db0304f0a596fa Mon Sep 17 00:00:00 2001
From: MadMaurice <madmaurice@zom.bi>
Date: Wed, 7 Apr 2021 23:16:44 +0200
Subject: [PATCH] Implement block mechanism and macros block, return and
 return-from

---
 lib/Minilisp.pm | 79 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 79 insertions(+)

diff --git a/lib/Minilisp.pm b/lib/Minilisp.pm
index b3dd445..99d5f05 100644
--- a/lib/Minilisp.pm
+++ b/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);