1 (in-package "SPECIALIZABLE")
4 ((used :initform nil :accessor used)))
6 (defun make-env (bindings env)
8 (defun find-binding (env var)
11 (defun bindings-from-ll (ll)
12 (mapcar (lambda (n) (cons n (make-instance 'binding))) ll))
14 (define-condition walker-warning (warning)
15 ((env :initarg :env :reader env)
16 (call-stack :initarg :call-stack :reader call-stack)))
17 (define-condition unused-variable (walker-warning)
18 ((name :initarg :name :reader name)))
19 (define-condition unbound-variable-referenced (walker-warning)
20 ((name :initarg :name :reader name)))
23 (defgeneric walk (form env vars)
24 (:generic-function-class cons-generic-function))
26 (defmethod walk ((expr cons) env call-stack)
27 (let ((cs (cons expr call-stack)))
28 (when (consp (car expr))
29 (walk (car expr) env cs))
30 (dolist (e (cdr expr))
31 (walk e env (cons e cs)))))
32 (defmethod walk ((expr symbol) env call-stack)
35 (let ((binding (find-binding env expr)))
37 (setf (used binding) t)
38 (warn 'unbound-variable-referenced :name expr
39 :env env :call-stack call-stack)))))
40 (defmethod walk ((expr t) env call-stack)
42 (defmacro with-checked-bindings ((bindings env call-stack) &body body)
43 `(let* ((bindings ,bindings)
44 (,env (make-env bindings ,env)))
46 (dolist (binding bindings)
47 (unless (used (cdr binding))
48 (warn 'unused-variable :name (car binding)
49 :env ,env :call-stack ,call-stack)))))
50 (defmethod walk ((expr (cons lambda)) env call-stack)
51 (let ((lambda-list (cadr expr))
53 (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
55 (walk form env (cons form call-stack))))))
56 (defmethod walk ((expr (cons multiple-value-bind)) env call-stack)
57 (let ((lambda-list (cadr expr))
58 (value-form (caddr expr))
60 (walk value-form env (cons value-form call-stack))
61 (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
63 (walk form env (cons form call-stack))))))
64 (defmethod walk ((expr (cons let)) env call-stack)
65 (flet ((let-binding (x)
66 (walk (cadr x) env (cons (cadr x) call-stack))
67 (cons (car x) (make-instance 'binding))))
68 (with-checked-bindings ((mapcar #'let-binding (cadr expr)) env call-stack)
69 (dolist (form (cddr expr))
70 (walk form env (cons form call-stack))))))
72 (defun walk/case (expr env call-stack)
77 (let ((binding (find-binding env expr)))
79 (setf (used binding) t)
80 (warn 'unbound-variable-referenced :name expr
81 :env env :call-stack call-stack)))))
83 (let ((lambda-list (cadr expr))
85 (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
87 (walk/case form env (cons form call-stack))))))
88 ((cons (eql multiple-value-bind))
89 (let ((lambda-list (cadr expr))
90 (value-form (caddr expr))
92 (walk/case value-form env (cons value-form call-stack))
93 (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
95 (walk/case form env (cons form call-stack))))))
96 ((cons (eql macrolet)))
99 ((cons (eql symbol-macrolet)))
102 ((cons (eql tagbody)))
103 ((cons (eql return-from)))
104 ((cons (eql multiple-value-call)))
109 (with-checked-bindings ((mapcar (lambda (x) (walk/case (cadr x) env (cons (cadr x) call-stack)) (cons (car x) (make-instance 'binding))) (cadr expr)) env call-stack)
110 (dolist (form (cddr expr))
111 (walk/case form env (cons form call-stack)))))
113 (let ((cs (cons expr call-stack)))
114 (when (consp (car expr))
115 (walk/case (car expr) env cs))
116 (dolist (e (cdr expr))
117 (walk/case e env (cons e cs)))))
120 (defgeneric walk/meth (expr env call-stack))
122 (defmethod walk/meth ((expr symbol) env call-stack)
125 (let ((binding (find-binding env expr)))
127 (setf (used binding) t)
128 (warn 'unbound-variable-referenced :name expr
129 :env env :call-stack call-stack)))))
130 (defmethod walk/meth ((expr t) env call-stack)
133 (defmethod walk/meth ((expr cons) env call-stack)
136 (let ((lambda-list (cadr expr))
138 (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
140 (walk/meth form env (cons form call-stack))))))
141 ((cons (eql multiple-value-bind))
142 (let ((lambda-list (cadr expr))
143 (value-form (caddr expr))
145 (walk/meth value-form env (cons value-form call-stack))
146 (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
148 (walk/meth form env (cons form call-stack))))))
149 ((cons (eql macrolet)))
151 ((cons (eql labels)))
152 ((cons (eql symbol-macrolet)))
155 ((cons (eql tagbody)))
156 ((cons (eql return-from)))
157 ((cons (eql multiple-value-call)))
162 (with-checked-bindings ((mapcar (lambda (x) (walk/meth (cadr x) env (cons (cadr x) call-stack)) (cons (car x) (make-instance 'binding))) (cadr expr)) env call-stack)
163 (dolist (form (cddr expr))
164 (walk/meth form env (cons form call-stack)))))
166 (let ((cs (cons expr call-stack)))
167 (when (consp (car expr))
168 (walk/meth (car expr) env cs))
169 (dolist (e (cdr expr))
170 (walk/meth e env (cons e cs)))))))