Christophe Weblog Wiki Code Publications Music
distinct walker which actually does something
[specializable.git] / walker.lisp
1 (in-package "SPECIALIZABLE")
2
3 (defclass binding ()
4   ((used :initform nil :accessor used)))
5
6 (defun make-env (bindings env)
7   (append bindings env))
8 (defun find-binding (env var)
9   (cdr (assoc var env)))
10
11 (defun bindings-from-ll (ll)
12   (mapcar (lambda (n) (cons n (make-instance 'binding))) ll))
13
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)))
21
22 (fmakunbound 'walk)
23 (defgeneric walk (form env vars)
24   (:generic-function-class cons-generic-function))
25
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)
33   (if (constantp expr)
34       nil
35       (let ((binding (find-binding env expr)))
36         (if binding
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)
41   nil)
42 (defmacro with-checked-bindings ((bindings env call-stack) &body body)
43   `(let* ((bindings ,bindings)
44           (,env (make-env bindings ,env)))
45      ,@body
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))
52         (body (cddr expr)))
53     (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
54       (dolist (form body)
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))
59         (body (cdddr expr)))
60     (walk value-form env (cons value-form call-stack))
61     (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
62       (dolist (form body)
63         (walk form env (cons form call-stack))))))
64 (defmethod walk ((expr (cons let)) env call-stack)
65   (with-checked-bindings ((mapcar (lambda (x) (walk (cadr x) env (cons (cadr x) call-stack)) (cons (car  x) (make-instance 'binding))) (cadr expr)) env call-stack)
66     (dolist (form (cddr expr))
67       (walk form env (cons form call-stack)))))
68
69 (defun walk/case (expr env call-stack)
70   (typecase expr
71     (symbol
72      (if (constantp expr)
73          nil
74          (let ((binding (find-binding env expr)))
75            (if binding
76                (setf (used binding) t)
77                (warn 'unbound-variable-referenced :name expr
78                      :env env :call-stack call-stack)))))
79     ((cons (eql lambda))
80      (let ((lambda-list (cadr expr))
81            (body (cddr expr)))
82        (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
83          (dolist (form body)
84            (walk/case form env (cons form call-stack))))))
85     ((cons (eql multiple-value-bind))
86      (let ((lambda-list (cadr expr))
87            (value-form (caddr expr))
88            (body (cdddr expr)))
89        (walk/case value-form env (cons value-form call-stack))
90        (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
91          (dolist (form body)
92            (walk/case form env (cons form call-stack))))))
93     ((cons (eql macrolet)))
94     ((cons (eql flet)))
95     ((cons (eql labels)))
96     ((cons (eql symbol-macrolet)))
97     ((cons (eql if)))
98     ((cons (eql progn)))
99     ((cons (eql tagbody)))
100     ((cons (eql return-from)))
101     ((cons (eql multiple-value-call)))
102     ((cons (eql block)))
103     ((cons (eql catch)))
104     ((cons (eql throw)))
105     ((cons (eql let))
106      (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)
107        (dolist (form (cddr expr))
108          (walk/case form env (cons form call-stack)))))
109     (cons
110      (let ((cs (cons expr call-stack)))
111        (when (consp (car expr))
112          (walk/case (car expr) env cs))
113        (dolist (e (cdr expr))
114          (walk/case e env (cons e cs)))))
115     (t)))
116
117 (defgeneric walk/meth (expr env call-stack))
118
119 (defmethod walk/meth ((expr symbol) env call-stack)
120   (if (constantp expr)
121          nil
122          (let ((binding (find-binding env expr)))
123            (if binding
124                (setf (used binding) t)
125                (warn 'unbound-variable-referenced :name expr
126                      :env env :call-stack call-stack)))))
127 (defmethod walk/meth ((expr t) env call-stack)
128   nil)
129
130 (defmethod walk/meth ((expr cons) env call-stack)
131   (typecase expr
132     ((cons (eql lambda))
133      (let ((lambda-list (cadr expr))
134            (body (cddr expr)))
135        (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
136          (dolist (form body)
137            (walk/meth form env (cons form call-stack))))))
138     ((cons (eql multiple-value-bind))
139      (let ((lambda-list (cadr expr))
140            (value-form (caddr expr))
141            (body (cdddr expr)))
142        (walk/meth value-form env (cons value-form call-stack))
143        (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
144          (dolist (form body)
145            (walk/meth form env (cons form call-stack))))))
146     ((cons (eql macrolet)))
147     ((cons (eql flet)))
148     ((cons (eql labels)))
149     ((cons (eql symbol-macrolet)))
150     ((cons (eql if)))
151     ((cons (eql progn)))
152     ((cons (eql tagbody)))
153     ((cons (eql return-from)))
154     ((cons (eql multiple-value-call)))
155     ((cons (eql block)))
156     ((cons (eql catch)))
157     ((cons (eql throw)))
158     ((cons (eql let))
159      (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)
160        (dolist (form (cddr expr))
161          (walk/meth form env (cons form call-stack)))))
162     (t
163      (let ((cs (cons expr call-stack)))
164        (when (consp (car expr))
165          (walk/meth (car expr) env cs))
166        (dolist (e (cdr expr))
167          (walk/meth e env (cons e cs)))))))