micros/walker: add defmethod

contrib/walker/defmethod-form.lisp

@@ -0,0 +1,95 @@
+(in-package :micros/walker)
+
+(defclass defmethod-form (ast)
+  ((name :initarg :name
+         :reader ast-name)
+   (lambda-list :initarg :lambda-list
+                :reader ast-lambda-list)
+   (body :initarg :body
+         :type implict-progn-form
+         :reader ast-body)))
+
+(defun take-method-qualifiers (args)
+  (let ((method-qualifiers
+          (loop :while (typep (first args) 'non-list)
+                :collect (pop args))))
+    (values method-qualifiers args)))
+
+(defmethod walk-specialized-lambda-list ((walker walker) specialized-lambda-list env path)
+  (let ((walked-lambda-list '())
+        (initial-forms '()))
+    (labels ((add (binding path)
+               (setf env (extend-env env binding))
+               (push (make-instance 'lambda-list-variable-form
+                                    :binding binding
+                                    :path path)
+                     walked-lambda-list)))
+      (loop :with state := nil
+            :for n :from 0
+            :for arg :in specialized-lambda-list
+            :do (case arg
+                  ((&aux &key &rest &body &optional)
+                   (setf state arg))
+                  (otherwise
+                   (ecase state
+                     ((&rest &body)
+                      (assert-type arg 'variable-symbol)
+                      (add (make-instance 'lexical-variable-binding :name arg) ; TODO: special variable
+                           (cons n path)))
+                     ((&key &optional &aux)
+                      (let* ((var-value (uiop:ensure-list arg))
+                             (var (first var-value))
+                             (value (second var-value)))
+                        (assert-type var 'variable-symbol)
+                        (let ((initial-value
+                                (when value
+                                  (walk walker value env (list* 1 n path)))))
+                          (when initial-value
+                            (push initial-value initial-forms))
+                          (add (make-instance 'lexical-variable-binding ; TODO: special variable
+                                              :name var
+                                              :value initial-value)
+                               (if (consp arg)
+                                   (list* 0 n path)
+                                   (cons n path))))))
+                     ((nil)
+                      (with-walker-bindings (var specializer)
+                          (if (consp arg) arg (list arg t))
+                        (declare (ignore specializer))
+                        (assert-type var 'variable-symbol)
+                        (add (make-instance 'lexical-variable-binding :name var) ; TODO: special variable
+                             (if (consp arg)
+                                 (list* 0 n path)
+                                 (cons n path))))))))))
+    (values (make-instance 'lambda-list-form
+                           :variables walked-lambda-list
+                           :initial-forms initial-forms
+                           :path path)
+            env)))
+
+(defmethod walk-form ((walker walker) (name (eql 'defmethod)) form env path)
+  (with-walker-bindings (name &rest args) (rest form)
+    (multiple-value-bind (method-qualifiers args)
+        (take-method-qualifiers args)
+      (with-walker-bindings (specialized-lambda-list &body body) args
+        (multiple-value-bind (specialized-lambda-list env)
+            (walk-specialized-lambda-list walker
+                                          specialized-lambda-list
+                                          env
+                                          (cons (+ 2 (length method-qualifiers)) path))
+          ;; TODO: declare
+          (make-instance 'defmethod-form
+                         :name name
+                         :path (cons 0 path)
+                         :lambda-list specialized-lambda-list
+                         :body (make-instance 'implict-progn-form
+                                              :forms (walk-forms walker
+                                                                 body
+                                                                 env
+                                                                 path
+                                                                 (+ 3 (length method-qualifiers)))
+                                              :path path)))))))
+
+(defmethod visit (visitor (ast defmethod-form))
+  (visit visitor (ast-lambda-list ast))
+  (visit visitor (ast-body ast)))

contrib/walker/example.lisp

@@ -88,3 +88,12 @@
   (let ((a 0))
     (with-foo ((aaa ))
       a)))
+
+(defmethod add (x y)
+  (+ x y))
+
+(defmethod add ((x integer) (y integer))
+  (+ x y))
+
+(defmethod add :before ((x integer) (y integer))
+  (print (list x y)))

contrib/walker/tests/tests.lisp

@@ -1683,8 +1683,41 @@
     ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (DEFUN F (X Y) X Y X Y) (4)) ((6) (4) (1 2)))
     ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (DEFUN F (X Y) X Y X Y) (3)) ((5) (3) (0 2)))
     ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (DEFUN F (X Y) X Y X Y) (1 2)) ((6) (4) (1 2)))
-    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (DEFUN F (X Y) X Y X Y) (0 2)) ((5) (3) (0 2)))))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (DEFUN F (X Y) X Y X Y) (0 2)) ((5) (3) (0 2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (DEFMETHOD ADD (X Y) (+ X Y)) (2 3)) ((2 3) (1 2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (DEFMETHOD ADD (X Y) (+ X Y)) (1 3)) ((1 3) (0 2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (DEFMETHOD ADD (X Y) (+ X Y)) (1 2)) ((2 3) (1 2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (DEFMETHOD ADD (X Y) (+ X Y)) (0 2)) ((1 3) (0 2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (DEFMETHOD MICROS/WALKER::ADD (MICROS/WALKER::X MICROS/WALKER::Y) (+ MICROS/WALKER::X MICROS/WALKER::Y))
+      (2 3))
+     ((2 3) (1 2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (DEFMETHOD MICROS/WALKER::ADD (MICROS/WALKER::X MICROS/WALKER::Y) (+ MICROS/WALKER::X MICROS/WALKER::Y))
+      (1 3))
+     ((1 3) (0 2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (DEFMETHOD MICROS/WALKER::ADD (MICROS/WALKER::X MICROS/WALKER::Y) (+ MICROS/WALKER::X MICROS/WALKER::Y))
+      (1 2))
+     ((2 3) (1 2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS
+      (DEFMETHOD MICROS/WALKER::ADD (MICROS/WALKER::X MICROS/WALKER::Y) (+ MICROS/WALKER::X MICROS/WALKER::Y))
+      (0 2))
+     ((1 3) (0 2)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (DEFMETHOD ADD :BEFORE ((X INTEGER) (Y INTEGER)) (PRINT (LIST X Y)))
+      (2 1 4))
+     ((2 1 4) (0 1 3)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (DEFMETHOD ADD :BEFORE ((X INTEGER) (Y INTEGER)) (PRINT (LIST X Y)))
+      (1 1 4))
+     ((1 1 4) (0 0 3)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (DEFMETHOD ADD :BEFORE ((X INTEGER) (Y INTEGER)) (PRINT (LIST X Y)))
+      (0 1 3))
+     ((2 1 4) (0 1 3)))
+    ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (DEFMETHOD ADD :BEFORE ((X INTEGER) (Y INTEGER)) (PRINT (LIST X Y)))
+      (0 0 3))
+     ((1 1 4) (0 0 3)))))
 
 (deftest random
   (loop :for (act-form expected) :in *test-cases*
-        :do (ok (equal expected (apply (first act-form) (rest act-form))))))
+        :do (ok (equal expected (apply (first act-form) (rest act-form)))
+                (format nil "~S" act-form))))

micros.asd

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