micros/walker: add something operators

contrib/walker/TODO

@@ -1,91 +1,98 @@
-- [ ] DEFINE-MODIFY-MACRO
-- [X] LOOP
-- [X] NTH-VALUE
-- [X] CHECK-TYPE
-- [ ] COND
-- [X] WITH-INPUT-FROM-STRING: with-single-binding-form
-- [ ] DEFCONSTANT
-- [ ] WITH-COMPILATION-UNIT
-- [ ] DEFPARAMETER
-- [ ] SETF
-- [ ] DEFINE-METHOD-COMBINATION
-- [ ] DEFINE-SYMBOL-MACRO
-- [ ] WITH-STANDARD-IO-SYNTAX
-- [ ] DEFSETF
-- [ ] RETURN
-- [ ] UNTRACE
-- [ ] RESTART-BIND
-- [ ] DEFSTRUCT
-- [ ] WITH-OPEN-STREAM
-- [ ] DO
-- [ ] PUSH
-- [ ] WITH-HASH-TABLE-ITERATOR
-- [ ] DO-SYMBOLS
-- [ ] TIME
-- [ ] DEFMACRO
-- [ ] PSETQ
-- [ ] DO-EXTERNAL-SYMBOLS
-- [ ] PROG*
-- [ ] DEFINE-COMPILER-MACRO
-- [ ] PPRINT-EXIT-IF-LIST-EXHAUSTED
-- [X] OR
-- [ ] DO-ALL-SYMBOLS
-- [ ] TYPECASE
-- [ ] IN-PACKAGE
-- [ ] DOTIMES
-- [ ] PROG2
-- [ ] DEFGENERIC
-- [ ] MULTIPLE-VALUE-BIND
-- [ ] DEFPACKAGE
-- [ ] PUSHNEW
-- [ ] DEFCLASS
-- [ ] POP
-- [ ] WITH-PACKAGE-ITERATOR
-- [ ] CALL-METHOD
-- [ ] WITH-CONDITION-RESTARTS
-- [ ] HANDLER-BIND
-- [X] WITH-OPEN-FILE: with-single-binding-form
-- [ ] WITH-SLOTS
-- [ ] SHIFTF
-- [ ] PPRINT-POP
-- [ ] ASSERT
-- [X] LAMBDA
-- [X] AND
-- [ ] TRACE
-- [X] WITH-OUTPUT-TO-STRING: with-single-binding-form
-- [ ] ROTATEF
-- [ ] CASE
-- [ ] MULTIPLE-VALUE-SETQ
-- [ ] MULTIPLE-VALUE-LIST
-- [ ] ETYPECASE
-- [ ] PPRINT-LOGICAL-BLOCK
-- [ ] WITH-SIMPLE-RESTART
-- [ ] PRINT-UNREADABLE-OBJECT
-- [ ] FORMATTER
-- [ ] PROG1
-- [ ] RESTART-CASE
-- [ ] WHEN
-- [ ] REMF
-- [ ] CTYPECASE
-- [ ] IGNORE-ERRORS
-- [ ] LOOP-FINISH
-- [ ] PROG
-- [ ] UNLESS
-- [ ] DECLAIM
-- [ ] DEFINE-CONDITION
-- [ ] DEFINE-SETF-EXPANDER
-- [X] DEFUN
-- [ ] HANDLER-CASE
-- [ ] CCASE
-- [ ] DO*
-- [ ] ECASE
-- [ ] WITH-ACCESSORS
-- [ ] STEP
-- [X] DECF
-- [ ] DEFVAR
-- [ ] DESTRUCTURING-BIND
-- [X] DEFMETHOD
-- [X] INCF
-- [ ] PSETF
-- [ ] DOLIST
-- [ ] DEFTYPE
+;; -*- mode:lisp -*-
+
+- [X] DEFUN 3154
+- [X] SETF 1685
+- [X] WHEN 1397
+- [X] OR 921
+- [X] AND 895
+- [X] DEFMETHOD 719
+- [X] LAMBDA 683
+- [X] LOOP 637
+- [X] UNLESS 581
+- [ ] DEFVAR 524
+- [X] RETURN 522
+- [ ] COND 446
+- [ ] DO 442
+- [X] IN-PACKAGE 379
+- [ ] DEFPACKAGE 272
+- [ ] DEFCLASS 235
+- [ ] PUSH 161
+- [ ] DOLIST 161
+- [ ] DEFGENERIC 158
+- [ ] ASSERT 158
+- [ ] MULTIPLE-VALUE-BIND 157
+- [ ] CHECK-TYPE 143
+- [ ] DEFMACRO 141
+- [ ] CASE 114
+- [X] INCF 113
+- [ ] HANDLER-CASE 100
+- [ ] DEFPARAMETER 97
+- [ ] DESTRUCTURING-BIND 91
+- [ ] DEFSTRUCT 90
+- [ ] WITH-OUTPUT-TO-STRING 68
+- [X] DECF 52
+- [ ] DOTIMES 48
+- [ ] ETYPECASE 42
+- [ ] PROG1 41
+- [ ] IGNORE-ERRORS 39
+- [ ] ECASE 38
+- [ ] DEFINE-CONDITION 37
+- [ ] WITH-SLOTS 35
+- [ ] DEFTYPE 30
+- [ ] POP 29
+- [ ] HANDLER-BIND 28
+- [ ] WITH-OPEN-FILE 24
+- [ ] MULTIPLE-VALUE-LIST 23
+- [ ] DEFCONSTANT 23
+- [ ] PUSHNEW 22
+- [ ] TIME 19
+- [ ] TYPECASE 18
+- [ ] WITH-INPUT-FROM-STRING 18
+- [ ] TRACE 17
+- [ ] ROTATEF 15
+- [X] NTH-VALUE 14
+- [ ] PRINT-UNREADABLE-OBJECT 12
+- [ ] DECLAIM 11
+- [ ] MULTIPLE-VALUE-SETQ 10
+- [ ] WITH-OPEN-STREAM 9
+- [ ] WITH-ACCESSORS 8
+- [ ] PROG 7
+- [ ] DEFINE-COMPILER-MACRO 5
+- [ ] RESTART-CASE 5
+- [ ] WITH-STANDARD-IO-SYNTAX 5
+- [ ] DEFINE-SYMBOL-MACRO 4
+- [ ] PROG2 4
+- [ ] STEP 3
+- [ ] DEFSETF 3
+- [ ] DEFINE-SETF-EXPANDER 3
+- [ ] DEFINE-MODIFY-MACRO 3
+- [ ] CCASE 3
+- [ ] CTYPECASE 3
+- [ ] RESTART-BIND 3
+- [ ] WITH-COMPILATION-UNIT 3
+- [ ] WITH-CONDITION-RESTARTS 3
+- [ ] DO-ALL-SYMBOLS 2
+- [ ] PPRINT-LOGICAL-BLOCK 2
+- [ ] PSETF 2
+- [ ] UNTRACE 2
+- [ ] DEFINE-METHOD-COMBINATION 2
+- [ ] WITH-HASH-TABLE-ITERATOR 2
+- [ ] WITH-PACKAGE-ITERATOR 2
+- [ ] WITH-SIMPLE-RESTART 2
+- [ ] DO-EXTERNAL-SYMBOLS 2
+- [ ] CALL-METHOD 1
+- [ ] DO-SYMBOLS 1
+- [ ] FORMATTER 1
+- [ ] LOOP-FINISH 1
+- [ ] PPRINT-EXIT-IF-LIST-EXHAUSTED 1
+- [ ] PPRINT-POP 1
+- [ ] PSETQ 1
+- [ ] REMF 1
+- [ ] SHIFTF 1
+
+* ローカル関数の(setf ...)を扱えない
+(let (storage)
+  (flet (((setf storage) (value)
+           (setf storage value)))
+    (setf (storage) 100))
+  storage)

contrib/walker/data-and-control-flow.lisp

@@ -1,51 +1,110 @@
 (in-package #:micros/walker)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
+  (defstruct walker-lambda-list-spec
+    required-arguments
+    optional-arguments
+    optional-position
+    rest-variable
+    rest-pos)
+
+  (defun all-arguments (spec)
+    (append (walker-lambda-list-spec-required-arguments spec)
+            (when (walker-lambda-list-spec-rest-variable spec)
+              (list (walker-lambda-list-spec-rest-variable spec)))
+            (walker-lambda-list-spec-optional-arguments spec)))
+
+  (defun parse-walker-lambda-list (lambda-list)
+    (let ((rest-pos (or (position '&rest lambda-list)
+                        (position '&body lambda-list)))
+          (optional-pos (position '&optional lambda-list)))
+      (make-walker-lambda-list-spec
+       :required-arguments (subseq lambda-list 0 (or optional-pos rest-pos))
+       :optional-arguments (when optional-pos (subseq lambda-list (1+ optional-pos)))
+       :optional-position optional-pos
+       :rest-variable (when rest-pos (elt lambda-list (1+ rest-pos)))
+       :rest-pos rest-pos)))
+
   (defun reader-name (symbol)
     (intern (format nil "AST-~A" symbol)))
 
-  (defun expand-simple-walker-defclass (walker-name arguments)
+  (defun expand-simple-walker-defclass (walker-name spec)
     `(defclass ,walker-name (ast)
-       ,(loop :for argument :in arguments
+       ,(loop :for argument
+              :in (all-arguments spec)
               :collect `(,argument :initarg ,(make-keyword argument)
                                    :reader ,(reader-name argument)))))
 
   (defun expand-simple-walker-defmethod-walk-form
-      (walker-name operator-name arguments)
-    (with-gensyms (walker name form env path)
+      (walker-name operator-name spec)
+    (with-gensyms (walker name form env path arg)
       `(defmethod walk-form ((,walker walker)
                              (,name (eql ',operator-name))
                              ,form ,env ,path)
-         (make-instance ',walker-name
-                        ,@(loop :for argument :in arguments
-                                :for n :from 1
-                                :collect (make-keyword argument)
-                                :collect `(walk ,walker
-                                                (elt ,form ,n)
-                                                ,env
-                                                (cons ,n ,path)))))))
-
-  (defun expand-simple-walker-defmethod-visit (walker-name arguments)
+         (make-instance
+          ',walker-name
+          ,@(loop :for argument :in (walker-lambda-list-spec-required-arguments spec)
+                  :for n :from 1
+                  :collect (make-keyword argument)
+                  :collect `(walk ,walker
+                                  (elt ,form ,n)
+                                  ,env
+                                  (cons ,n ,path)))
+          ,@(when (walker-lambda-list-spec-optional-position spec)
+              (loop :for argument :in (walker-lambda-list-spec-optional-arguments spec)
+                    :for n :from (1+ (walker-lambda-list-spec-optional-position spec))
+                    :collect (make-keyword argument)
+                    :collect `(let ((,arg (nth ,n ,form)))
+                                (when ,arg
+                                  (walk ,walker
+                                        ,arg
+                                        ,env
+                                        (cons ,n ,path))))))
+          ,@(when (walker-lambda-list-spec-rest-variable spec)
+              (with-gensyms (var n)
+                `(,(make-keyword (walker-lambda-list-spec-rest-variable spec))
+                  (loop :for ,var :in (nthcdr ,(walker-lambda-list-spec-rest-pos spec) ,form)
+                        :for ,n :from ,(walker-lambda-list-spec-rest-pos spec)
+                        :collect (walk ,walker ,var ,env (cons ,n ,path))))))))))
+
+  (defun expand-simple-walker-defmethod-visit (walker-name spec)
     (with-gensyms (visitor ast)
       `(defmethod visit (,visitor (,ast ,walker-name))
-         ,@(loop :for argument :in arguments
-                 :collect `(visit ,visitor (,(reader-name argument) ,ast))))))
+         ,@(loop :for argument :in (walker-lambda-list-spec-required-arguments spec)
+                 :collect `(visit ,visitor (,(reader-name argument) ,ast)))
+         ,@(loop :for argument :in (walker-lambda-list-spec-optional-arguments spec)
+                 :collect `(when (,(reader-name argument) ,ast)
+                             (visit ,visitor (,(reader-name argument) ,ast))))
+         ,(when (walker-lambda-list-spec-rest-variable spec)
+            `(visit-foreach ,visitor
+                            (,(reader-name (walker-lambda-list-spec-rest-variable spec)) ,ast))))))
 
-  (defun expand-simple-walker (walker-name operator-name arguments)
-    `(progn
-       ,(expand-simple-walker-defclass walker-name arguments)
-       ,(expand-simple-walker-defmethod-walk-form walker-name
-                                                  operator-name
-                                                  arguments)
-       ,(expand-simple-walker-defmethod-visit walker-name arguments))))
+  (defun expand-simple-walker (walker-name operator-name lambda-list)
+    (let ((spec (parse-walker-lambda-list lambda-list)))
+      `(progn
+         ,(expand-simple-walker-defclass
+           walker-name
+           spec)
+         ,(expand-simple-walker-defmethod-walk-form
+           walker-name
+           operator-name
+           spec)
+         ,(expand-simple-walker-defmethod-visit
+           walker-name
+           spec)))))
 
-(defmacro def-simple-walker (walker-name operator-name &rest arguments)
-  (expand-simple-walker walker-name operator-name arguments))
+(defmacro def-simple-walker (walker-name operator-name lambda-list)
+  (expand-simple-walker walker-name operator-name lambda-list))
 
-(def-simple-walker nth-value-form nth-value n form)
-(def-simple-walker or-form or n form)
-(def-simple-walker incf-form incf n form)
-(def-simple-walker decf-form decf n form)
+(def-simple-walker nth-value-form nth-value (n form))
+(def-simple-walker incf-form incf (n form))
+(def-simple-walker decf-form decf (n form))
+(def-simple-walker or-form or (&rest forms))
+(def-simple-walker and-form and (&rest forms))
+(def-simple-walker when-form when (test &body forms))
+(def-simple-walker unless-form unless (test &body forms))
+(def-simple-walker return-form return (&optional value))
+(def-simple-walker in-package-form in-package (string-designator))
 
 ;; check-type
 (defclass check-type-form (ast)
@@ -65,3 +124,59 @@
 (defmethod visit (visitor (ast check-type-form))
   (visit visitor (ast-place ast))
   (visit visitor (ast-type-string ast)))
+
+;; setf
+(defclass setf-form (ast)
+  ((forms :initarg :forms
+          :reader ast-forms)))
+
+(defclass setf-symbol-form (ast)
+  ((var :initarg :var
+        :type binding
+        :reader ast-var)
+   (value :initarg :value
+          :reader ast-value)))
+
+(defclass setf-complex-form (ast)
+  ((operator :initarg :operator
+             :type variable-symbol
+             :reader ast-operator)
+   (arguments :initarg :arguments
+              :reader ast-arguments)
+   (value :initarg :value
+          :reader ast-value)))
+
+(defmethod walk-form ((walker walker) (name (eql 'setf)) form env path)
+  (make-instance
+   'setf-form
+   :path path
+   :forms (loop :for (place value) :on (rest form) :by #'cddr
+                :for n :from 1 :by 2
+                :for walked-value := (walk walker
+                                           value
+                                           env
+                                           (cons (1+ n) path))
+                :collect (if (symbolp place)
+                             (make-instance 'setf-symbol-form
+                                            :var (walk-variable walker place env (cons n path))
+                                            :value walked-value)
+                             (make-instance 'setf-complex-form
+                                            :operator (first place)
+                                            :arguments (loop :for m :from 1
+                                                             :for arg :in (rest place)
+                                                             :collect (walk walker
+                                                                            arg
+                                                                            env
+                                                                            (list* m n path)))
+                                            :value walked-value)))))
+
+(defmethod visit (visitor (ast setf-form))
+  (visit-foreach visitor (ast-forms ast)))
+
+(defmethod visit (visitor (ast setf-symbol-form))
+  (visit visitor (ast-var ast))
+  (visit visitor (ast-value ast)))
+
+(defmethod visit (visitor (ast setf-complex-form))
+  (visit-foreach visitor (ast-arguments ast))
+  (visit visitor (ast-value ast)))