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)))))))