micros/walker: add loop-form (wip)

contrib/walker/example.lisp

@@ -116,3 +116,14 @@
 
 (with-open-file (in filename)
   (read-line in))
+
+(let ((x 0))
+  (loop (f x)))
+
+(loop :with x := 0
+      :with y := x
+      :with z := (f x y))
+
+(loop :with x := 0
+      :return :it
+      :return (f x))

contrib/walker/loop-form.lisp

@@ -0,0 +1,219 @@
+(in-package :micros/walker)
+
+(defclass simple-loop-form (ast)
+  ((body :initarg :body
+         :type implict-progn-form
+         :reader ast-body)))
+
+(defclass loop-form (ast)
+  ((named :initarg :named
+          :type variable-symbol
+          :reader loop-form-named)
+   (with-clauses :initarg :with-clauses
+     :type (proper-list with-clause)
+     :reader loop-form-with-clauses)
+   (initial-clauses :initarg :initial-clauses
+                    :type (proper-list initial-clause)
+                    :reader loop-form-initial-clauses)
+   (fianl-clauses :initarg :final-clauses
+                  :type (proper-list final-clause)
+                  :reader loop-form-final-clauses)
+   (doing-forms :initarg :doing-forms
+                :type (proper-list ast)
+                :reader loop-form-doing-forms)
+   (return-forms :initarg :return-forms
+                 :type (proper-list ast)
+                 :reader loop-form-return-forms)))
+
+(defclass with-clause (ast <with-binding-form>)
+  ((binding :initarg :binding
+            :reader ast-binding)
+   (value :initarg :value
+          :reader ast-value)))
+
+(defclass initial-clause (ast)
+  ((forms :initarg :forms
+          :type (proper-list ast)
+          :reader ast-forms)))
+
+(defclass final-clause (ast)
+  ((forms :initarg :forms
+          :type (proper-list ast)
+          :reader ast-forms)))
+
+(defclass it-form (ast)
+  ())
+
+(defmethod walk-complex-loop-form ((walker walker) form env path)
+  (assert (and (proper-list-p form) (eq 'loop (first form))))
+  (let ((pos 0)
+        (exps (rest form))
+        (named-binding nil)
+        (with-clauses '())
+        (initial-clauses '())
+        (final-clauses '())
+        (doing-forms '())
+        (return-forms '()))
+    (labels ((lookahead ()
+               (first exps))
+             (next ()
+               (walker-assert (not (null exps)))
+               (incf pos)
+               (pop exps))
+             (accept (name)
+               (when (and (typep (lookahead) '(or symbol string))
+                          (string= name (lookahead)))
+                 (next)
+                 t))
+             (exact-var ()
+               (let ((var (next)))
+                 (assert-type var 'variable-symbol)
+                 var))
+
+             (name-clause ()
+               (when (accept :named)
+                 (let ((named (next)))
+                   (assert-type named 'variable-symbol)
+                   (setf named-binding (make-instance 'block-binding :name named))
+                   (extend-env env named-binding))))
+             (variable-clause ()
+               (when (or (with-clause)
+                         (initial-final)
+                         (for-as-clause))
+                 t))
+             (variable-clause* ()
+               (loop :while (variable-clause)))
+             (with-clause ()
+               (when (accept :with)
+                 (let ((with-clauses*
+                           (loop :for var := (exact-var) ; TODO: d-var-spec
+                                 :do (type-spec)
+                                 :collect (make-instance
+                                           'with-clause
+                                           :path (cons pos path)
+                                           :binding (make-instance 'lexical-variable-binding
+                                                                   :name var)
+                                           :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*)))))
+             (main-clause ()
+               (or (unconditional)
+                   (accumulation)
+                   (conditional)
+                   (termination-test)
+                   (initial-final)
+                   ))
+             (main-clause* ()
+               (loop :while (main-clause)))
+             (initial-final ()
+               (cond ((accept :initially)
+                      (push (make-instance 'initial-clause :forms (compound-forms))
+                            initial-clauses))
+                     ((accept :finally)
+                      (push (make-instance 'final-clause :forms (compound-forms))
+                            final-clauses))))
+             (unconditional ()
+               (cond ((or (accept :do)
+                          (accept :doing))
+                      (setf doing-forms (append doing-forms (compound-forms))))
+                     ((accept :return)
+                      (if (accept :it)
+                          (push (make-instance 'it-form :path (cons pos path))
+                                return-forms)
+                          (let ((form (next)))
+                            (push (walk walker form env (cons pos path))
+                                  return-forms))))))
+             (accumulation ()
+               ;; TODO
+               )
+             (conditional ()
+               ;; TODO
+               )
+             (termination-test ()
+               ;; TODO
+               )
+             (for-as-clause ()
+               (loop :while (or (accept :for) (accept :as))
+                     :collect (for-as-subclause)))
+             (for-as-subclause ()
+               (let ((var (exact-var)))
+                 (type-spec)
+                 (let ((binding (make-instance 'lexical-variable-binding :name var)))
+                   (declare (ignore binding))
+                   (cond ((accept :in)
+                          )
+                         ((accept :on)
+                          )
+                         ((accept :=)
+                          )
+                         ((accept :across)
+                          )
+                         ((accept :being)
+                          )
+                         (t
+                          ;; TODO: error
+                          )))))
+             (type-spec ()
+               (cond ((member (lookahead) '(t nil fixnum float))
+                      (next)
+                      t)
+                     ((accept :of-type)
+                      (next)
+                      t)
+                     (t
+                      nil)))
+             (compound-forms ()
+               (let ((exp (next)))
+                 (walker-assert (consp exp))
+                 (cons (walk walker exp env (cons pos path))
+                       (loop :for exp := (lookahead)
+                             :while (consp exp)
+                             :collect (walk walker exp env (cons pos path))
+                             :do (next))))))
+      (name-clause)
+      (variable-clause*)
+      (main-clause*)
+      (make-instance 'loop-form
+                     :named named-binding
+                     :with-clauses (nreverse with-clauses)
+                     :initial-clauses (nreverse initial-clauses)
+                     :final-clauses (nreverse final-clauses)
+                     :doing-forms (nreverse doing-forms)
+                     :return-forms (nreverse return-forms)))))
+
+(defmethod walk-form ((walker walker) (name (eql 'loop)) form env path)
+  (with-walker-bindings (&body forms) (rest form)
+    (if (and forms (symbolp (first forms)))
+        (walk-complex-loop-form walker form env path)
+        (make-instance 'simple-loop-form
+                       :body (make-instance 'implict-progn-form
+                                            :path path
+                                            :forms (walk-forms walker forms env path 1))))))
+
+(defmethod visit (visitor (ast loop-form))
+  (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-doing-forms ast))
+  (visit-foreach visitor (loop-form-return-forms ast)))
+
+(defmethod visit (visitor (ast with-clause))
+  (visit visitor (ast-value ast)))
+
+(defmethod visit (visitor (ast initial-clause))
+  (visit-foreach visitor (ast-forms ast)))
+
+(defmethod visit (visitor (ast final-clause))
+  (visit-foreach visitor (ast-forms ast)))
+
+(defmethod visit (visitor (ast it-form))
+  nil)
+
+(defmethod visit (visitor (ast simple-loop-form))
+  (visit visitor (ast-body ast)))

contrib/walker/tests/tests.lisp

@@ -1736,7 +1736,69 @@
         ((LAMBDA (COMMON-LISP-USER::A) (DECLARE (SPECIAL COMMON-LISP-USER::A)) COMMON-LISP-USER::A))
         COMMON-LISP-USER::A)
       (3 0 3))
-     ((3 0 4) (0 1 0 4) (3 0 3) (0 1 0 3)))))
+     ((3 0 4) (0 1 0 4) (3 0 3) (0 1 0 3)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LET ((X 0))
+        (LOOP (F X)))
+      (1 1 2))
+     ((1 1 2) (0 0 1)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LET ((X 0))
+        (LOOP (F X)))
+      (0 0 1))
+     ((1 1 2) (0 0 1)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH X := 0
+            :WITH Y := X
+            :WITH Z := (F X Y))
+      (2 12))
+     ((6) (2 12)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH X := 0
+            :WITH Y := X
+            :WITH Z := (F X Y))
+      (1 12))
+     ((2) (8) (1 12)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH X := 0
+            :WITH Y := X
+            :WITH Z := (F X Y))
+      (8))
+     ((2) (8) (1 12)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH X := 0
+            :WITH Y := X
+            :WITH Z := (F X Y))
+      (10))
+     ((10)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH X := 0
+            :WITH Y := X
+            :WITH Z := (F X Y))
+      (6))
+     ((6) (2 12)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH X := 0
+            :WITH Y := X
+            :WITH Z := (F X Y))
+      (2))
+     ((2) (8) (1 12)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH X := 0
+            :DO (F X))
+      (1 6))
+     ((1 6) (2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (LOOP :WITH X := 0
+            :DO (F X))
+      (2))
+     ((1 6) (2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (LOOP :WITH X := 0 :RETURN :IT :RETURN (F X)) (6))
+     NIL)
+    ((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)))))
 
 (deftest random
   (loop :for (act-form expected) :in *test-cases*

contrib/walker/walker.lisp

@@ -717,7 +717,7 @@
                                                                  path
                                                                  2))))))))
 
-(defun walk-macro-1 (walker form path env lambda-list)
+(defun walk-macro (walker form path env lambda-list)
   (let ((body-pos (position '&body lambda-list)))
     (cond (;; (with-* (var &rest forms) &body body)
            (and (string-prefix-p "WITH-" (string (first form)))
@@ -736,13 +736,6 @@
                                                  (1+ body-pos)))
                (error 'unimplemented :context form))))))
 
-(defmethod walk-macro ((walker walker) form env path expansion)
-  (walk-macro-1 walker
-                form
-                path
-                env
-                (micros/backend:arglist (first form))))
-
 (defmethod walk-lambda-call-form ((walker walker) form env path)
   (with-walker-bindings (lambda-form &rest args) form
     (make-instance 'lambda-call-form
@@ -754,14 +747,11 @@
 (defmethod walk-form ((walker walker) name form env path)
   (let ((macrolet-binding (lookup-macrolet-binding env name)))
     (if macrolet-binding
-        (walk-macro-1 walker
-                      form
-                      path
-                      env
-                      (macrolet-binding-lambda-list macrolet-binding))
+        (walk-macro walker form path env (macrolet-binding-lambda-list macrolet-binding))
         (multiple-value-bind (expansion expanded) (macroexpand-1 form)
+          (declare (ignore expansion))
           (if expanded
-              (walk-macro walker form env path expansion)
+              (walk-macro walker form path env (micros/backend:arglist (first form)))
               (let ((name (first form)))
                 (if (consp name)
                     (walk-lambda-call-form walker form env path)

micros.asd

@@ -53,7 +53,8 @@
                                            (:file "types")
                                            (:file "walker")
                                            (:file "defun-form")
-                                           (:file "defmethod-form")))))
+                                           (:file "defmethod-form")
+                                           (:file "loop-form")))))
                (:file "lsp-api")))
 
 (defsystem "micros/tests"