micros/walker: add d-var-spec

lem-project · Nov 12, 2023 · 6019c1f · 6019c1f
1 parent 00a814b
commit 6019c1f
Show file tree

Hide file tree

Showing 3 changed files with 110 additions and 10 deletions.
diff --git a/contrib/walker/example.lisp b/contrib/walker/example.lisp
@@ -127,3 +127,10 @@
 (loop :with x := 0
       :return :it
       :return (f x))
+
+(loop :with (x . y) := (f)
+      :with a := x
+      :with b := y)
+
+(loop :with ((x y) . z) := (f)
+      :with a := (+ x y z))
diff --git a/contrib/walker/loop-form.lisp b/contrib/walker/loop-form.lisp
@@ -25,9 +25,14 @@
                  :type (proper-list ast)
                  :reader loop-form-return-forms)))
 
-(defclass with-clause (ast <with-binding-form>)
+(defclass d-var (ast <with-binding-form>)
   ((binding :initarg :binding
-            :reader ast-binding)
+            :reader ast-binding)))
+
+(defclass with-clause (ast)
+  ((d-vars :initarg :d-vars
+           :type (proper-list d-var)
+           :reader ast-d-vars)
    (value :initarg :value
           :reader ast-value)))
 
@@ -44,6 +49,29 @@
 (defclass it-form (ast)
   ())
 
+(defun walk-d-var-spec (walker d-var-spec env path)
+  (cond ((null d-var-spec)
+         '())
+        ((atom d-var-spec)
+         (assert-type d-var-spec 'variable-symbol)
+         (list (make-instance 'd-var
+                              :binding (make-instance 'lexical-variable-binding
+                                                      :name d-var-spec)
+                              :path path)))
+        (t
+         (loop :for (elt . rest) :on d-var-spec
+               :for n :from 0
+               :append (walk-d-var-spec walker elt env (cons n path)) :into acc
+               :finally (if (null rest)
+                            (return acc)
+                            (return
+                              (append acc
+                                      (walk-d-var-spec walker
+                                                       rest
+                                                       env
+                                                       ;; Represents the path of b in (a . b)
+                                                       (cons (+ n 2) path)))))))))
+
 (defmethod walk-complex-loop-form ((walker walker) form env path)
   (assert (and (proper-list-p form) (eq 'loop (first form))))
   (let ((pos 0)
@@ -70,6 +98,10 @@
                  (assert-type var 'variable-symbol)
                  var))
 
+             (d-var-spec (path)
+               (let ((d-var-spec (next)))
+                 (walk-d-var-spec walker d-var-spec env path)))
+
              (name-clause ()
                (when (accept :named)
                  (let ((named (next)))
@@ -85,23 +117,26 @@
                (loop :while (variable-clause)))
              (with-clause ()
                (when (accept :with)
-                 (let ((with-clauses*
-                           (loop :for var := (exact-var) ; TODO: d-var-spec
+                 (let ((clauses
+                           (loop :for d-vars := (d-var-spec (cons (1+ pos) path))
                                  :do (type-spec)
                                  :collect (make-instance
                                            'with-clause
-                                           :path (cons pos path)
-                                           :binding (make-instance 'lexical-variable-binding
-                                                                   :name var)
+                                           :path nil ; TODO
+                                           :d-vars d-vars
                                            :value (when (accept :=)
                                                     (let ((value (walk walker
                                                                        (next)
                                                                        env
                                                                        (cons pos path))))
                                                       value)))
                                  :while (accept :and))))
-                   (setf env (extend-env* env (mapcar #'ast-binding with-clauses*)))
-                   (setf with-clauses (append with-clauses with-clauses*)))))
+                   (setf env
+                         (extend-env* env
+                                      (mapcan (lambda (clause)
+                                                (mapcar #'ast-binding (ast-d-vars clause)))
+                                              clauses)))
+                   (setf with-clauses (append with-clauses clauses)))))
              (main-clause ()
                (or (unconditional)
                    (accumulation)
@@ -196,6 +231,9 @@
                                             :path path
                                             :forms (walk-forms walker forms env path 1))))))
 
+(defmethod visit (visitor (ast d-var))
+  nil)
+
 (defmethod visit (visitor (ast loop-form))
   (visit-foreach visitor (loop-form-with-clauses ast))
   (visit-foreach visitor (loop-form-initial-clauses ast))
@@ -204,6 +242,7 @@
   (visit-foreach visitor (loop-form-return-forms ast)))
 
 (defmethod visit (visitor (ast with-clause))
+  (visit-foreach visitor (ast-d-vars ast))
   (visit visitor (ast-value ast)))
 
 (defmethod visit (visitor (ast initial-clause))

diff --git a/contrib/walker/tests/tests.lisp b/contrib/walker/tests/tests.lisp
@@ -1798,7 +1798,61 @@
     ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (LOOP :WITH X := 0 :RETURN :IT :RETURN (F X)) (1 8))
      ((1 8) (2)))
     ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (LOOP :WITH X := 0 :RETURN :IT :RETURN (F X)) (2))
-     ((1 8) (2)))))
+     ((1 8) (2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH ((X Y) . Z) := (F)
+            :WITH A := (+ X Y Z))
+      (3 8))
+     ((2 2) (3 8)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH ((X Y) . Z) := (F)
+            :WITH A := (+ X Y Z))
+      (2 8))
+     ((1 0 2) (2 8)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH ((X Y) . Z) := (F)
+            :WITH A := (+ X Y Z))
+      (1 8))
+     ((0 0 2) (1 8)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH ((X Y) . Z) := (F)
+            :WITH A := (+ X Y Z))
+      (2 2))
+     ((2 2) (3 8)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH ((X Y) . Z) := (F)
+            :WITH A := (+ X Y Z))
+      (1 0 2))
+     ((1 0 2) (2 8)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH ((X Y) . Z) := (F)
+            :WITH A := (+ X Y Z))
+      (0 0 2))
+     ((0 0 2) (1 8)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH (X . Y) := (F)
+            :WITH A := X
+            :WITH B := Y)
+      (12))
+     ((2 2) (12)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH (X . Y) := (F)
+            :WITH A := X
+            :WITH B := Y)
+      (8))
+     ((0 2) (8)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH (X . Y) := (F)
+            :WITH A := X
+            :WITH B := Y)
+      (2 2))
+     ((2 2) (12)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH (X . Y) := (F)
+            :WITH A := X
+            :WITH B := Y)
+      (0 2))
+     ((0 2) (8)))))
 
 (deftest random
   (loop :for (act-form expected) :in *test-cases*