Implement tagbody and go macros

lib/Minilisp.pm

@@ -479,6 +479,10 @@ sub parser_prog {
               {
                 die "Uncaught exception $1";
               }
+            elsif ($type eq "goto")
+              {
+                die "Target $@->{section} of go statement not found";
+              }
           }
         die "$@";
       }
@@ -1191,6 +1195,72 @@ sub macro_dolist {
 }
 $macros{dolist} = \&macro_dolist;
 
+sub macro_tagbody {
+  my $ts = shift;
+
+  my $init_symbol = bless({},"init");
+
+  my $parse_section = $init_symbol;
+  my %schedule;
+  my %sections;
+  $sections{$parse_section} = [];
+  while (!peek_token($ts, RPAREN))
+    {
+      if (peek_token($ts, IDENT))
+        {
+          my $next_parse_section = slurp_token($ts, IDENT)->{value};
+          $schedule{$parse_section} = $next_parse_section;
+          $parse_section = $next_parse_section;
+          $sections{$parse_section} = [];
+        }
+      else
+        {
+          push @{$sections{$parse_section}}, parser_expr($ts);
+        }
+    }
+
+  return sub {
+    my $octx = shift;
+    my $ictx = ctx_create($octx);
+
+    my $current_section = $init_symbol;
+
+    do {
+      eval {
+        $_->($ictx) foreach @{$sections{$current_section}};
+        1;
+      };
+      if ($@)
+        {
+          if (ref($@) eq "goto" && exists($sections{$@->{section}}))
+            {
+              $current_section = $@->{section}
+            }
+          else
+            {
+              die $@;
+            }
+        }
+      else
+        {
+          $current_section = $schedule{$current_section};
+        }
+    } while($current_section);
+  };
+}
+$macros{tagbody} = \&macro_tagbody;
+
+sub macro_go {
+  my $ts = shift;
+
+  my $ident = slurp_token($ts, IDENT, "Expected identifier after go")->{value};
+
+  return sub {
+    die bless({ section => $ident }, "goto");
+  };
+}
+$macros{go} = \&macro_go;
+
 sub compile {
   my ($term) = @_;
   my @tokens = tokenize($term);

t/tagbody.t

@@ -0,0 +1,28 @@
+(plan 2)
+
+(defun inc (n) (+ n 1))
+
+(expect "dotimes - sections are evaluated in order"
+        (equal 'ok
+               (catch 'test
+                 (let ((i 0))
+                   (tagbody
+                    (set i 's0)
+                    section-a
+                    (unless (equal i 's0) (throw 'test 'fail))
+                    (set i 's1)
+                    section-b
+                    (unless (equal i 's1) (throw 'test 'fail))
+                    (set i 's2))
+                   (unless (equal i 's2) (throw 'test 'fail)))
+                 'ok)))
+
+(expect "dotimes - go works"
+        (equal 'ok
+               (catch 'test
+                 (tagbody
+                  (go section-b)
+                  section-a
+                  (throw 'test 'fail)
+                  section-b)
+                 'ok)))