From 56cbc7107a1695d2831dc5d38062cb58a4e21c48 Mon Sep 17 00:00:00 2001
From: cxxxr <g23tlm@gmail.com>
Date: Sun, 17 Dec 2023 16:12:34 +0900
Subject: [PATCH] micros/walker: add tagbody/go form

---
 contrib/walker/example.lisp          |  7 ++++
 contrib/walker/tests/test-cases.lisp | 30 +++++++++++++++
 contrib/walker/walker.lisp           | 55 +++++++++++++++++++++++++++-
 3 files changed, 90 insertions(+), 2 deletions(-)

diff --git a/contrib/walker/example.lisp b/contrib/walker/example.lisp
index e0aa059..29e752f 100644
--- a/contrib/walker/example.lisp
+++ b/contrib/walker/example.lisp
@@ -286,3 +286,10 @@
 (defvar x
   (let ((foo 0))
     foo))
+
+(tagbody
+  (uiop:println 1)
+  (go foo)
+  (uiop:println 2)
+ foo
+  (uiop:println 3))
diff --git a/contrib/walker/tests/test-cases.lisp b/contrib/walker/tests/test-cases.lisp
index 46911d3..b15e9b7 100644
--- a/contrib/walker/tests/test-cases.lisp
+++ b/contrib/walker/tests/test-cases.lisp
@@ -3779,3 +3779,33 @@
     MICROS/WALKER::B)
   (0 0 1))
  ((2) (0 0 1)))
+((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+  (TAGBODY
+    (UIOP/STREAM:PRINTLN 1)
+    (GO MICROS/WALKER::FOO)
+    (GO MICROS/WALKER::FOO)
+    (UIOP/STREAM:PRINTLN 2)
+   MICROS/WALKER::FOO
+    (UIOP/STREAM:PRINTLN 3))
+  (5))
+ ((5) (1 3) (1 2)))
+((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+  (TAGBODY
+    (UIOP/STREAM:PRINTLN 1)
+    (GO MICROS/WALKER::FOO)
+    (GO MICROS/WALKER::FOO)
+    (UIOP/STREAM:PRINTLN 2)
+   MICROS/WALKER::FOO
+    (UIOP/STREAM:PRINTLN 3))
+  (1 3))
+ ((5) (1 3) (1 2)))
+((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+  (TAGBODY
+    (UIOP/STREAM:PRINTLN 1)
+    (GO MICROS/WALKER::FOO)
+    (GO MICROS/WALKER::FOO)
+    (UIOP/STREAM:PRINTLN 2)
+   MICROS/WALKER::FOO
+    (UIOP/STREAM:PRINTLN 3))
+  (1 2))
+ ((5) (1 3) (1 2)))
diff --git a/contrib/walker/walker.lisp b/contrib/walker/walker.lisp
index 4a497b2..5b25f3e 100644
--- a/contrib/walker/walker.lisp
+++ b/contrib/walker/walker.lisp
@@ -44,6 +44,7 @@
 (defclass special-variable-binding (binding) ())
 (defclass lexical-variable-binding (binding) ())
 (defclass lexical-function-binding (binding) ())
+(defclass tagbody-binding (binding) ())
 (defclass block-binding (binding) ())
 (defclass macrolet-binding (binding)
   ((lambda-list :initarg :lambda-list
@@ -71,6 +72,9 @@
 (defun lookup-macrolet-binding (env name)
   (lookup-binding env name 'macrolet-binding))
 
+(defun lookup-tagbody-binding (env name)
+  (lookup-binding env name 'tagbody-binding))
+
 (defun lookup-block-binding (env name)
   (lookup-binding env name 'block-binding))
 
@@ -218,6 +222,21 @@
    (value :initarg :value
           :reader ast-value)))
 
+(defclass tagbody-form (ast)
+  ((statements :type (proper-list (or ast tag))
+               :initarg :statements
+               :reader ast-statements)))
+
+(defclass tag (ast <with-binding-form>)
+  ((binding :type tagbody-binding
+            :initarg :binding
+            :reader ast-binding)))
+
+(defclass go-form (ast)
+  ((tag :type tag
+        :initarg :tag
+        :reader ast-tag)))
+
 (defclass the-form (ast)
   ((value-type :initarg :value-type
                :reader ast-value-type)
@@ -670,10 +689,30 @@
   (unimplemented name :form form :path path))
 
 (defmethod walk-form ((walker walker) (name (eql 'tagbody)) form env path)
-  (unimplemented name :form form :path path))
+  (with-walker-bindings (&rest statements) (rest form)
+    (let* ((bindings (mapcar (lambda (tag)
+                               (make-instance 'tagbody-binding :name tag))
+                             (remove-if-not #'symbolp statements)))
+           (env (extend-env* env bindings))
+           (statements
+             (loop :for statement :in statements
+                   :for n :from 1
+                   :collect (if (symbolp statement)
+                                (make-instance 'tag
+                                               :binding (lookup-tagbody-binding env statement)
+                                               :path (cons n path))
+                                (walk walker statement env (cons n path))))))
+      (make-instance 'tagbody-form
+                     :path (cons 0 path)
+                     :statements statements))))
 
 (defmethod walk-form ((walker walker) (name (eql 'go)) form env path)
-  (unimplemented name :form form :path path))
+  (with-walker-bindings (tag) (rest form)
+    (make-instance 'go-form
+                   :tag (make-instance 'tag
+                                       :binding (lookup-tagbody-binding env tag)
+                                       :path (cons 1 path))
+                   :path (cons 0 path))))
 
 (defmethod walk-form ((walker walker) (name (eql 'the)) form env path)
   (with-walker-bindings (value-type form) (rest form)
@@ -872,6 +911,18 @@
   (visit visitor (ast-proctected-form ast))
   (visit-foreach visitor (ast-cleanup-forms ast)))
 
+(defmethod visit (visitor (ast tagbody-form))
+  (visit-foreach visitor (ast-statements ast)))
+
+(defmethod visit (visitor (ast tag))
+  (values))
+
+(defmethod visit (visitor (ast go-form))
+  (visit visitor (ast-tag ast)))
+
+(defmethod visit (visitor (ast return-from-form))
+  (values))
+
 (defmethod visit (visitor (ast block-name-form))
   (values))