micros/walker: for-as-in-list

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

Hide file tree

Showing 3 changed files with 141 additions and 7 deletions.
diff --git a/contrib/walker/example.lisp b/contrib/walker/example.lisp
@@ -134,3 +134,9 @@
 
 (loop :with ((x y) . z) := (f)
       :with a := (+ x y z))
+
+(loop :for x :in '(1 2 3) :do (print x))
+(loop :with foo
+      :for x :in '(1 2 3) :do (print x))
+(loop :with foo := nil
+      :for x :in '(1 2 3) :do (print x))
diff --git a/contrib/walker/loop-form.lisp b/contrib/walker/loop-form.lisp
@@ -18,6 +18,8 @@
    (fianl-clauses :initarg :final-clauses
                   :type (proper-list final-clause)
                   :reader loop-form-final-clauses)
+   (for-as-clauses :initarg :for-as-clauses
+                   :reader loop-form-for-as-clauses)
    (doing-forms :initarg :doing-forms
                 :type (proper-list ast)
                 :reader loop-form-doing-forms)
@@ -49,6 +51,14 @@
 (defclass it-form (ast)
   ())
 
+(defclass for-as-in-list-clause (ast <with-binding-form>)
+  ((binding :initarg :binding
+            :reader ast-binding)
+   (in :initarg :in
+       :reader ast-in)
+   (by :initarg :by
+       :reader ast-by)))
+
 (defun walk-d-var-spec (walker d-var-spec env path)
   (cond ((null d-var-spec)
          '())
@@ -80,6 +90,7 @@
         (with-clauses '())
         (initial-clauses '())
         (final-clauses '())
+        (for-as-clauses '())
         (doing-forms '())
         (return-forms '()))
     (labels ((lookahead ()
@@ -180,20 +191,42 @@
                (let ((var (exact-var)))
                  (type-spec)
                  (let ((binding (make-instance 'lexical-variable-binding :name var)))
-                   (declare (ignore binding))
                    (cond ((accept :in)
-                          )
+                          (for-as-in-list binding))
                          ((accept :on)
-                          )
+                          (for-as-on-list))
                          ((accept :=)
-                          )
+                          (for-as-equals-then))
                          ((accept :across)
-                          )
+                          (for-as-across))
                          ((accept :being)
+                          ;; TODO
                           )
                          (t
                           ;; TODO: error
+                          ;; TODO: from, to, downfrom, downto, above, by
                           )))))
+             (for-as-in-list (binding)
+               (let* ((for-pos (- pos 2))
+                      (in (walk walker (next) env (cons (+ for-pos 3) path)))
+                      (by (when (accept :by)
+                            (walk walker (next) env (cons (+ for-pos 5) path)))))
+                 (push (make-instance 'for-as-in-list-clause
+                                      :path (cons (+ for-pos 1) path)
+                                      :binding binding
+                                      :in in
+                                      :by by)
+                       for-as-clauses)
+                 (setf env (extend-env env binding))))
+             (for-as-on-list ()
+               ;; TODO
+               )
+             (for-as-equals-then ()
+               ;; TODO
+               )
+             (for-as-across ()
+               ;; TODO
+               )
              (type-spec ()
                (cond ((member (lookahead) '(t nil fixnum float))
                       (next)
@@ -219,6 +252,7 @@
                      :with-clauses (nreverse with-clauses)
                      :initial-clauses (nreverse initial-clauses)
                      :final-clauses (nreverse final-clauses)
+                     :for-as-clauses (nreverse for-as-clauses)
                      :doing-forms (nreverse doing-forms)
                      :return-forms (nreverse return-forms)))))
 
@@ -238,12 +272,14 @@
   (visit-foreach visitor (loop-form-with-clauses ast))
   (visit-foreach visitor (loop-form-initial-clauses ast))
   (visit-foreach visitor (loop-form-final-clauses ast))
+  (visit-foreach visitor (loop-form-for-as-clauses ast))
   (visit-foreach visitor (loop-form-doing-forms ast))
   (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)))
+  (when (ast-value ast)
+    (visit visitor (ast-value ast))))
 
 (defmethod visit (visitor (ast initial-clause))
   (visit-foreach visitor (ast-forms ast)))
@@ -254,5 +290,9 @@
 (defmethod visit (visitor (ast it-form))
   nil)
 
+(defmethod visit (visitor (ast for-as-in-list-clause))
+  (visit visitor (ast-in ast))
+  (when (ast-by ast) (visit visitor (ast-by ast))))
+
 (defmethod visit (visitor (ast simple-loop-form))
   (visit visitor (ast-body ast)))
diff --git a/contrib/walker/tests/tests.lisp b/contrib/walker/tests/tests.lisp
@@ -1852,7 +1852,95 @@
             :WITH A := X
             :WITH B := Y)
       (0 2))
-     ((0 2) (8)))))
+     ((0 2) (8)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH FOO := NIL
+            :FOR X :IN '(1 2 3)
+            :DO (PRINT X))
+      (1 10))
+     ((1 10) (6)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH FOO := NIL
+            :FOR X :IN '(1 2 3)
+            :DO (PRINT X))
+      (6))
+     ((1 10) (6)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH FOO := NIL
+            :FOR X :IN '(1 2 3)
+            :DO (PRINT X))
+      (2))
+     ((2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH FOO
+            :FOR X :IN '(1 2 3)
+            :DO (PRINT X))
+      (1 8))
+     ((1 8) (4)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH FOO
+            :FOR X :IN '(1 2 3)
+            :DO (PRINT X))
+      (4))
+     ((1 8) (4)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH FOO
+            :FOR X :IN '(1 2 3)
+            :DO (PRINT X))
+      (2))
+     ((2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :FOR X :IN '(1 2 3)
+            :DO (PRINT X))
+      (1 6))
+     ((1 6) (2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :FOR X :IN '(1 2 3)
+            :DO (PRINT X))
+      (2))
+     ((1 6) (2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH FN := #'CDDR
+            :AND A
+            :FOR X :IN (LIST A) :BY FN
+            :DO (PRINT X))
+      (1 14))
+     ((1 14) (8)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH FN := #'CDDR
+            :AND A
+            :FOR X :IN (LIST A) :BY FN
+            :DO (PRINT X))
+      (12))
+     ((12) (2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH FN := #'CDDR
+            :AND A
+            :FOR X :IN (LIST A) :BY FN
+            :DO (PRINT X))
+      (1 10))
+     ((1 10) (6)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH FN := #'CDDR
+            :AND A
+            :FOR X :IN (LIST A) :BY FN
+            :DO (PRINT X))
+      (8))
+     ((1 14) (8)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH FN := #'CDDR
+            :AND A
+            :FOR X :IN (LIST A) :BY FN
+            :DO (PRINT X))
+      (6))
+     ((1 10) (6)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH FN := #'CDDR
+            :AND A
+            :FOR X :IN (LIST A) :BY FN
+            :DO (PRINT X))
+      (2))
+     ((12) (2)))))
 
 (deftest random
   (loop :for (act-form expected) :in *test-cases*