diff --git a/contrib/walker/example.lisp b/contrib/walker/example.lisp index 798a5e7..191084c 100644 --- a/contrib/walker/example.lisp +++ b/contrib/walker/example.lisp @@ -103,3 +103,13 @@ (+ a b)) 1 2) + +(let ((a 0)) + a + ((lambda (a) + (declare (special a)) + a)) + ((lambda (a) + (declare (special a)) + a)) + a) diff --git a/contrib/walker/tests/tests.lisp b/contrib/walker/tests/tests.lisp index c912013..fd9f96f 100644 --- a/contrib/walker/tests/tests.lisp +++ b/contrib/walker/tests/tests.lisp @@ -372,7 +372,7 @@ (MULTIPLE-VALUE-PROG1 A B A) (UNWIND-PROTECT A (THE INTEGER B) C)) (3 7)) - NIL) + ((3 7))) ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (LAMBDA (X A B C &KEY (Y X) Z &AUX (FOO 10)) X Y Z FOO) (0 1)) ((2) (1 5 1) (0 1))) ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (LAMBDA (X A B C &KEY (Y X) Z &AUX (FOO 10)) X Y Z FOO) (1 1)) @@ -549,7 +549,7 @@ (F X) #'F)) (1 2 2)) - NIL) + ((1 2 2))) ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (FLET ((F () )) @@ -560,7 +560,7 @@ (F X) #'F)) (1 2 2)) - NIL) + ((1 2 2))) ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (FLET ((F () )) @@ -808,7 +808,7 @@ B C)) (5 2)) - NIL) + ((5 2))) ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (LET ((A 0)) (DO ((X 1 (1+ X))) @@ -819,7 +819,7 @@ B C)) (6 2)) - NIL) + ((6 2))) ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (LET ((A 0)) (WITH-HOGE NIL A B C)) @@ -871,7 +871,7 @@ B C)) (6 2)) - NIL) + ((6 2))) ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (LET ((A 0)) (DO ((X 1 (1+ X))) @@ -882,7 +882,7 @@ B C)) (5 2)) - NIL) + ((5 2))) ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (LET ((A 0)) (DO ((X 1 (1+ X))) @@ -1130,7 +1130,7 @@ (F X) #'F)) (1 2 2)) - NIL) + ((1 2 2))) ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (FLET ((F () )) @@ -1141,7 +1141,7 @@ (F X) #'F)) (1 2 2)) - NIL) + ((1 2 2))) ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (FLET ((F () )) @@ -1318,7 +1318,7 @@ (MULTIPLE-VALUE-PROG1 A B A) (UNWIND-PROTECT A (THE INTEGER B) C)) (3 7)) - NIL) + ((3 7))) ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (LET ((A 0) (B 1)) (LOAD-TIME-VALUE A B) @@ -1728,9 +1728,18 @@ ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS ((LAMBDA (MICROS/WALKER::A MICROS/WALKER::B) (+ MICROS/WALKER::A MICROS/WALKER::B)) 1 2) (0 1 0)) - ((1 2 0) (0 1 0))))) + ((1 2 0) (0 1 0))) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (LET ((COMMON-LISP-USER::A 0)) + COMMON-LISP-USER::A + ((LAMBDA (COMMON-LISP-USER::A) (DECLARE (SPECIAL COMMON-LISP-USER::A)) COMMON-LISP-USER::A)) + ((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))))) (deftest random (loop :for (act-form expected) :in *test-cases* + :for n :from 0 :do (ok (equal expected (apply (first act-form) (rest act-form))) - (format nil "~S" act-form)))) + (format nil "~D ~S" n act-form)))) diff --git a/contrib/walker/walker.lisp b/contrib/walker/walker.lisp index 9779323..3c7452f 100644 --- a/contrib/walker/walker.lisp +++ b/contrib/walker/walker.lisp @@ -55,6 +55,7 @@ :reader binding-value :writer (setf binding-value)))) +(defclass special-variable-binding (binding) ()) (defclass lexical-variable-binding (binding) ()) (defclass lexical-function-binding (binding) ()) (defclass block-binding (binding) ()) @@ -68,14 +69,15 @@ (defun extend-env* (env bindings) (append bindings env)) -(defun lookup-binding (env name type) +(defun lookup-binding (env name &rest types) (loop :for binding :in env - :when (and (typep binding type) + :when (and (some (lambda (type) (typep binding type)) + types) (eq name (binding-name binding))) :return binding)) -(defun lookup-lexical-binding (env name) - (lookup-binding env name 'lexical-variable-binding)) +(defun lookup-variable (env name) + (lookup-binding env name 'lexical-variable-binding 'special-variable-binding)) (defun lookup-function-binding (env name) (lookup-binding env name 'lexical-function-binding)) @@ -139,7 +141,8 @@ :reader ast-initial-forms))) (defclass lambda-form (ast) - ((lambda-list :initarg :lambda-list :reader ast-lambda-list) + ((documentation :initarg :documentation :reader ast-documentation) + (lambda-list :initarg :lambda-list :reader ast-lambda-list) (body :initarg :body :reader ast-body))) (defclass multiple-value-call-form (ast) @@ -248,9 +251,10 @@ (arguments :initarg :arguments :reader ast-arguments))) -(defclass dynamic-variable (ast) - ((symbol :initarg :symbol - :reader ast-symbol))) +(defclass special-variable (ast) + ((binding :initarg :binding + :type special-variable-binding + :reader ast-binding))) (defclass lexical-variable (ast) ((binding :initarg :binding @@ -277,8 +281,37 @@ :type implict-progn-form :reader ast-body))) +;; +(defstruct declaration-spec + specials) + +(defun parse-declaration-specifiers (declare-forms) + (let ((specials '())) + (dolist (declare-form declare-forms) + (assert (eq 'declare (first declare-form))) + (dolist (specifier (rest declare-form)) + (assert-type specifier 'proper-list) + (case (first specifier) + ((special) + (setf specials (append specials (rest specifier))))))) + (make-declaration-spec :specials specials))) + ;; walker -(defclass walker () ()) +(defclass walker () + ((special-variable-table :initform (make-hash-table :test 'eq) + :reader walker-special-variable-table))) + +(defmethod get-special-variable-binding ((walker walker) symbol) + (or (gethash symbol (walker-special-variable-table walker)) + (setf (gethash symbol (walker-special-variable-table walker)) + (make-instance 'special-variable-binding :name symbol)))) + +(defun make-variable (walker declaration-spec name &optional value) + (declare (ignore value)) + (if (and declaration-spec + (member name (declaration-spec-specials declaration-spec))) + (get-special-variable-binding walker name) + (make-instance 'lexical-variable-binding :name name))) (defgeneric walk-form (walker name form env path)) @@ -423,7 +456,7 @@ :body (walk-forms walker body env path 2) :path (cons 0 path))))) -(defmethod walk-lambda-list ((walker walker) lambda-list env path) +(defmethod walk-lambda-list ((walker walker) lambda-list env path &key declaration-spec) (let ((walked-lambda-list '()) (initial-forms '())) (flet ((add (binding path) @@ -442,7 +475,7 @@ (ecase state ((&rest &body) (assert-type arg 'variable-symbol) - (add (make-instance 'lexical-variable-binding :name arg) ; TODO: special variable + (add (make-variable walker declaration-spec arg) (cons n path))) ((&key &optional &aux) (let* ((var-value (uiop:ensure-list arg)) @@ -454,14 +487,12 @@ (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) + (add (make-variable walker declaration-spec var initial-value) (if (consp arg) (list* 0 n path) (cons n path)))))) ((nil) - (add (make-instance 'lexical-variable-binding :name arg) ; TODO: special variable + (add (make-variable walker declaration-spec arg) (cons n path)))))))) (values (make-instance 'lambda-list-form :variables (nreverse walked-lambda-list) @@ -472,13 +503,20 @@ (defmethod walk-lambda-form ((walker walker) form env path) (assert-type (first form) '(member lambda #+sbcl sb-int:named-lambda)) (with-walker-bindings (lambda-list &body body) (rest form) - (multiple-value-bind (lambda-list env) - (walk-lambda-list walker lambda-list env (cons 1 path)) - ;; TODO: declare - (make-instance 'lambda-form - :lambda-list lambda-list - :body (walk-forms walker body env path 2) - :path (cons 0 path))))) + (multiple-value-bind (body declare-forms documentation) + (parse-body body :documentation t) + (let ((declaration-spec (parse-declaration-specifiers declare-forms))) + (multiple-value-bind (lambda-list env) + (walk-lambda-list walker + lambda-list + env + (cons 1 path) + :declaration-spec declaration-spec) + (make-instance 'lambda-form + :documentation documentation + :lambda-list lambda-list + :body (walk-forms walker body env path (+ 2 (length declare-forms))) + :path (cons 0 path))))))) (defmethod walk-form ((walker walker) (name (eql 'function)) form env path) (with-walker-bindings (thing) (rest form) @@ -697,14 +735,19 @@ :path (cons 0 path))))))))))) (defmethod walk-variable ((walker walker) symbol env path) - (declare (ignore walker)) ;; TODO ;; - symbol-macro ;; - constant - (let ((binding (lookup-lexical-binding env symbol))) - (if binding - (make-instance 'lexical-variable :binding binding :path path) - (make-instance 'dynamic-variable :symbol symbol :path path)))) + (let ((binding (lookup-variable env symbol))) + (typecase binding + (lexical-variable-binding + (make-instance 'lexical-variable :binding binding :path path)) + (special-variable-binding + (make-instance 'special-variable :binding binding :path path)) + (null + (make-instance 'special-variable + :binding (get-special-variable-binding walker symbol) + :path path))))) (defun walk (walker form env path) (cond ((null form) @@ -819,7 +862,7 @@ (visit visitor (ast-lambda-form ast)) (visit-foreach visitor (ast-arguments ast))) -(defmethod visit (visitor (ast dynamic-variable)) +(defmethod visit (visitor (ast special-variable)) (values)) (defmethod visit (visitor (ast lexical-variable)) @@ -856,15 +899,16 @@ (defclass binding-collector (visitor) ((target-binding :initarg :target-binding :initform (error "Missing :target-binding") - :reader visitor-target-binding) + :reader binding-collector-target-binding) (found-paths :initform '() - :accessor visitor-found-paths))) + :accessor binding-collector-found-paths))) (defun visit-binding-collector (visitor ast) - (when (eq (visitor-target-binding visitor) + (when (eq (binding-collector-target-binding visitor) (ast-binding ast)) - (push (ast-path ast) - (visitor-found-paths visitor)))) + (when (ast-path ast) + (push (ast-path ast) + (binding-collector-found-paths visitor))))) (defmethod visit ((visitor binding-collector) (ast let-binding-form)) (visit-binding-collector visitor ast) @@ -882,6 +926,10 @@ (visit-binding-collector visitor ast) (call-next-method)) +(defmethod visit ((visitor binding-collector) (ast special-variable)) + (visit-binding-collector visitor ast) + (call-next-method)) + (defmethod visit ((visitor binding-collector) (ast local-function-form)) (visit-binding-collector visitor ast) (call-next-method)) @@ -917,6 +965,7 @@ ((or block-name-form let-binding-form lexical-variable + special-variable lambda-list-variable-form flet-binding-form local-function-form @@ -926,7 +975,7 @@ :target-binding (ast-binding (exit-visitor-value c))))) (visit visitor ast) - (visitor-found-paths visitor))))))))) + (binding-collector-found-paths visitor))))))))) (when *record-test-cases* (push `((collect-highlight-paths ,form ,path) ,result) *test-cases*))