examples/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   (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))))))
  71
  72 (defun walk/case (expr env call-stack)
  73   (typecase expr
  74     (symbol
  75      (if (constantp expr)
  76          nil
  77          (let ((binding (find-binding env expr)))
  78            (if binding
  79                (setf (used binding) t)
  80                (warn 'unbound-variable-referenced :name expr
  81                      :env env :call-stack call-stack)))))
  82     ((cons (eql lambda))
  83      (let ((lambda-list (cadr expr))
  84            (body (cddr expr)))
  85        (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
  86          (dolist (form body)
  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))
  91            (body (cdddr expr)))
  92        (walk/case value-form env (cons value-form call-stack))
  93        (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
  94          (dolist (form body)
  95            (walk/case form env (cons form call-stack))))))
  96     ((cons (eql macrolet)))
  97     ((cons (eql flet)))
  98     ((cons (eql labels)))
  99     ((cons (eql symbol-macrolet)))
 100     ((cons (eql if)))
 101     ((cons (eql progn)))
 102     ((cons (eql tagbody)))
 103     ((cons (eql return-from)))
 104     ((cons (eql multiple-value-call)))
 105     ((cons (eql block)))
 106     ((cons (eql catch)))
 107     ((cons (eql throw)))
 108     ((cons (eql let))
 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)))))
 112     (cons
 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)))))
 118     (t)))
 119
 120 (defgeneric walk/meth (expr env call-stack))
 121
 122 (defmethod walk/meth ((expr symbol) env call-stack)
 123   (if (constantp expr)
 124          nil
 125          (let ((binding (find-binding env expr)))
 126            (if binding
 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)
 131   nil)
 132
 133 (defmethod walk/meth ((expr cons) env call-stack)
 134   (typecase expr
 135     ((cons (eql lambda))
 136      (let ((lambda-list (cadr expr))
 137            (body (cddr expr)))
 138        (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
 139          (dolist (form body)
 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))
 144            (body (cdddr expr)))
 145        (walk/meth value-form env (cons value-form call-stack))
 146        (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
 147          (dolist (form body)
 148            (walk/meth form env (cons form call-stack))))))
 149     ((cons (eql macrolet)))
 150     ((cons (eql flet)))
 151     ((cons (eql labels)))
 152     ((cons (eql symbol-macrolet)))
 153     ((cons (eql if)))
 154     ((cons (eql progn)))
 155     ((cons (eql tagbody)))
 156     ((cons (eql return-from)))
 157     ((cons (eql multiple-value-call)))
 158     ((cons (eql block)))
 159     ((cons (eql catch)))
 160     ((cons (eql throw)))
 161     ((cons (eql let))
 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)))))
 165     (t
 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)))))))