From 7ca4bad9b00aba590bd124e4ecedbd9a07281373 Mon Sep 17 00:00:00 2001
From: MadMaurice <madmaurice@zom.bi>
Date: Tue, 6 Apr 2021 22:11:37 +0200
Subject: [PATCH] Implement do macro

---
 lib/Minilisp.pm | 90 +++++++++++++++++++++++++++++++++++++++++++++++++
 t/do.t          | 13 +++++++
 2 files changed, 103 insertions(+)
 create mode 100644 t/do.t

diff --git a/lib/Minilisp.pm b/lib/Minilisp.pm
index 6e360bf..2ed7772 100644
--- a/lib/Minilisp.pm
+++ b/lib/Minilisp.pm
@@ -474,6 +474,11 @@ sub slurp_token {
   return $tok;
 }
 
+sub peek_token {
+  my ($ts, $type) = @_;
+  return $ts->[0]->{type} == $type;
+}
+
 sub parser_list {
   my $ts = shift;
 
@@ -826,6 +831,91 @@ sub macro_or {
 }
 $macros{or} = \&macro_or;
 
+sub macro_do {
+  my $ts = shift;
+
+  slurp_token($ts, LPAREN, "Expected ( after do");
+
+  my @vars;
+
+  while(!peek_token($ts, RPAREN))
+    {
+      my $name = undef;
+      my $init = undef;
+      my $step = undef;
+
+      if (peek_token($ts, IDENT))
+        {
+          $name = slurp_token($ts,IDENT)->{value};
+        }
+      else
+        {
+          slurp_token($ts, LPAREN, "Expected either identifier or ( in var list");
+
+          $name = slurp_token($ts, IDENT)->{value};
+
+          if ( !peek_token($ts, RPAREN) )
+            {
+              $init = parser_expr($ts);
+
+              if ( !peek_token($ts, RPAREN) )
+                {
+                  $step = parser_expr($ts);
+                }
+            }
+
+          slurp_token($ts, RPAREN, "Expected ) after var");
+        }
+
+      push @vars, {
+        name => $name,
+        init => $init,
+        step => $step,
+      };
+    }
+
+  slurp_token($ts, RPAREN, "Expected ) after var list");
+
+  slurp_token($ts, LPAREN, "Expected ( before end-test-form");
+
+  my $end_test_form = parser_expr($ts);
+
+  my $result_form = macro_progn($ts);
+
+  slurp_token($ts, RPAREN, "Expected ) after resultform");
+
+  my $body = macro_progn($ts);
+
+  return sub {
+    my $octx = shift;
+    my $ictx = ctx_create($octx);
+
+    foreach my $var (@vars)
+      {
+        my $val = undef;
+        $val = $var->{init}->($octx) if defined $var->{init};
+        ctx_set($ictx, $var->{name}, $val);
+      }
+
+    while ( !from_lisp_bool($end_test_form->($ictx)) )
+      {
+        $body->($ictx);
+
+        my %steps;
+        foreach my $var (@vars)
+          {
+            next unless defined $var->{step};
+            $steps{$var->{name}} = $var->{step}->($ictx);
+          }
+
+        ctx_set($ictx, $_, $steps{$_}) foreach (keys %steps);
+      }
+
+    return $result_form->($ictx);
+  }
+}
+$macros{do} = \&macro_do;
+
 sub compile {
   my ($term) = @_;
   my @tokens = tokenize($term);
diff --git a/t/do.t b/t/do.t
new file mode 100644
index 0000000..e9bad3c
--- /dev/null
+++ b/t/do.t
@@ -0,0 +1,13 @@
+(expect "do - simple example"
+        (equal (do ((n 1)) (t n)) 1))
+
+(defun range (start end)
+  (do ((i (- end 1) (- i 1))
+       (lst (list) (cons i lst)))
+      ((< i start) lst)))
+
+(expect "do - range function"
+        (equal (let ((lst (range 1 4)))
+                 (comment lst)
+                 lst)
+               (list 1 2 3)))