1 ;;;; code-walker.lisp --- TODO.
3 ;;;; Copyright (C) 2013, 2014 Christophe Rhodes
4 ;;;; Copyright (C) 2014 Jan Moringen
6 ;;;; Author: Christophe Rhodes
8 ;;;; Partially based on TODO
10 (cl:defpackage #:pattern-specializer.examples.code-walker
13 #:pattern-specializer)
15 (:import-from #:specializable
16 #:cons-generic-function)
18 (:import-from #:optima
21 (cl:in-package #:pattern-specializer.examples.code-walker)
24 ((used :initform nil :accessor used)))
26 (defun make-env (bindings env)
27 (append bindings env))
28 (defun find-binding (env var)
29 (cdr (assoc var env)))
31 (defun bindings-from-ll (ll)
32 (mapcar (lambda (n) (cons n (make-instance 'binding))) ll))
34 (define-condition walker-warning (warning)
35 ((env :initarg :env :reader env)
36 (call-stack :initarg :call-stack :reader call-stack)))
37 (define-condition unused-variable (walker-warning)
38 ((name :initarg :name :reader name)))
39 (define-condition unbound-variable-referenced (walker-warning)
40 ((name :initarg :name :reader name)))
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)))))
53 (defgeneric walk/cons (form env vars)
54 (:generic-function-class cons-generic-function))
56 (defmethod walk/cons ((expr t) env call-stack)
59 (defmethod walk/cons ((expr cons) env call-stack)
60 (let ((cs (cons expr call-stack)))
61 (when (consp (car expr))
62 (walk/cons (car expr) env cs))
63 (dolist (e (cdr expr))
64 (walk/cons e env (cons e cs)))))
66 (defmethod walk/cons ((expr symbol) env call-stack)
69 (let ((binding (find-binding env expr)))
71 (setf (used binding) t)
72 (warn 'unbound-variable-referenced :name expr
73 :env env :call-stack call-stack)))))
75 (defmethod walk/cons ((expr (cons lambda)) env call-stack)
76 (let ((lambda-list (cadr expr))
78 (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
80 (walk/cons form env (cons form call-stack))))))
82 (defmethod walk/cons ((expr (cons multiple-value-bind)) env call-stack)
83 (let ((lambda-list (cadr expr))
84 (value-form (caddr expr))
86 (walk/cons value-form env (cons value-form call-stack))
87 (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
89 (walk/cons form env (cons form call-stack))))))
91 (defmethod walk/cons ((expr (cons let)) env call-stack)
92 (flet ((let-binding (x)
93 (walk/cons (cadr x) env (cons (cadr x) call-stack))
94 (cons (car x) (make-instance 'binding))))
95 (with-checked-bindings ((mapcar #'let-binding (cadr expr)) env call-stack)
96 (dolist (form (cddr expr))
97 (walk/cons form env (cons form call-stack))))))
101 (defun walk-binding-form-body (bindings body env call-stack)
102 (with-checked-bindings (bindings env call-stack)
104 (walk/pattern form env (cons form call-stack)))))
106 (defgeneric walk/pattern (form env vars)
107 (:generic-function-class pattern-generic-function))
109 (defmethod walk/pattern ((expr t) env call-stack)
112 (defmethod walk/pattern ((expr cons) env call-stack)
113 (let ((cs (cons expr call-stack)))
114 (when (consp (car expr))
115 (walk/pattern (car expr) env cs))
116 (dolist (e (cdr expr))
117 (walk/pattern e env (cons e cs)))))
119 (defmethod walk/pattern ((expr (pattern (type (and symbol (not (satisfies constantp)))))) env call-stack)
120 (let ((binding (find-binding env expr)))
122 (setf (used binding) t)
123 (warn 'unbound-variable-referenced :name expr
124 :env env :call-stack call-stack))))
126 (defmethod walk/pattern ((expr (pattern (list* 'lambda lambda-list body))) env call-stack)
127 (walk-binding-form-body
128 (bindings-from-ll lambda-list) body env call-stack))
130 (defmethod walk/pattern ((expr (pattern (list* 'multiple-value-bind lambda-list value-form body))) env call-stack)
131 (walk/pattern value-form env (cons value-form call-stack))
132 (walk-binding-form-body
133 (bindings-from-ll lambda-list) body env call-stack))
135 (defmethod walk/pattern ((expr (pattern (list* 'let bindings body))) env call-stack)
136 (flet ((let-binding (binding)
137 (destructuring-bind (name value) binding
138 (walk/pattern value env (cons value call-stack))
139 (cons name (make-instance 'binding)))))
140 (walk-binding-form-body
141 (mapcar #'let-binding bindings) body env call-stack)))
145 (defun walk/case (expr env call-stack)
150 (let ((binding (find-binding env expr)))
152 (setf (used binding) t)
153 (warn 'unbound-variable-referenced :name expr
154 :env env :call-stack call-stack)))))
156 (let ((lambda-list (cadr expr))
158 (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
160 (walk/case form env (cons form call-stack))))))
161 ((cons (eql multiple-value-bind))
162 (let ((lambda-list (cadr expr))
163 (value-form (caddr expr))
165 (walk/case value-form env (cons value-form call-stack))
166 (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
168 (walk/case form env (cons form call-stack))))))
169 ((cons (eql macrolet)))
171 ((cons (eql labels)))
172 ((cons (eql symbol-macrolet)))
175 ((cons (eql tagbody)))
176 ((cons (eql return-from)))
177 ((cons (eql multiple-value-call)))
182 (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)
183 (dolist (form (cddr expr))
184 (walk/case form env (cons form call-stack)))))
186 (let ((cs (cons expr call-stack)))
187 (when (consp (car expr))
188 (walk/case (car expr) env cs))
189 (dolist (e (cdr expr))
190 (walk/case e env (cons e cs)))))
195 (defgeneric walk/meth (expr env call-stack))
197 (defmethod walk/meth ((expr symbol) env call-stack)
200 (let ((binding (find-binding env expr)))
202 (setf (used binding) t)
203 (warn 'unbound-variable-referenced :name expr
204 :env env :call-stack call-stack)))))
205 (defmethod walk/meth ((expr t) env call-stack)
208 (defmethod walk/meth ((expr cons) env call-stack)
211 (let ((lambda-list (cadr expr))
213 (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
215 (walk/meth form env (cons form call-stack))))))
216 ((cons (eql multiple-value-bind))
217 (let ((lambda-list (cadr expr))
218 (value-form (caddr expr))
220 (walk/meth value-form env (cons value-form call-stack))
221 (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
223 (walk/meth form env (cons form call-stack))))))
224 ((cons (eql macrolet)))
226 ((cons (eql labels)))
227 ((cons (eql symbol-macrolet)))
230 ((cons (eql tagbody)))
231 ((cons (eql return-from)))
232 ((cons (eql multiple-value-call)))
237 (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)
238 (dolist (form (cddr expr))
239 (walk/meth form env (cons form call-stack)))))
241 (let ((cs (cons expr call-stack)))
242 (when (consp (car expr))
243 (walk/meth (car expr) env cs))
244 (dolist (e (cdr expr))
245 (walk/meth e env (cons e cs)))))))