examples/code-walker.lisp

   1 ;;;; code-walker.lisp --- TODO.
   2 ;;;;
   3 ;;;; Copyright (C) 2013, 2014 Christophe Rhodes
   4 ;;;; Copyright (C) 2014 Jan Moringen
   5 ;;;;
   6 ;;;; Author: Christophe Rhodes
   7
   8 ;;;; Partially based on TODO
   9
  10 (cl:defpackage #:pattern-specializer.examples.code-walker
  11   (:use
  12    #:cl
  13    #:pattern-specializer)
  14
  15   (:import-from #:specializable
  16    #:cons-generic-function)
  17
  18   (:import-from #:optima
  19    #:guard))
  20
  21 (cl:in-package #:pattern-specializer.examples.code-walker)
  22
  23 (defclass binding ()
  24   ((used :initform nil :accessor used)))
  25
  26 (defun make-env (bindings env)
  27   (append bindings env))
  28 (defun find-binding (env var)
  29   (cdr (assoc var env)))
  30
  31 (defun bindings-from-ll (ll)
  32   (mapcar (lambda (n) (cons n (make-instance 'binding))) ll))
  33
  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)))
  41
  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
  51 ;;; walk/cons
  52
  53 (defgeneric walk/cons (form env vars)
  54   (:generic-function-class cons-generic-function))
  55
  56 (defmethod walk/cons ((expr t) env call-stack)
  57   nil)
  58
  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)))))
  65
  66 (defmethod walk/cons ((expr symbol) env call-stack)
  67   (if (constantp expr)
  68       nil
  69       (let ((binding (find-binding env expr)))
  70         (if binding
  71             (setf (used binding) t)
  72             (warn 'unbound-variable-referenced :name expr
  73                   :env env :call-stack call-stack)))))
  74
  75 (defmethod walk/cons ((expr (cons lambda)) env call-stack)
  76   (let ((lambda-list (cadr expr))
  77         (body (cddr expr)))
  78     (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
  79       (dolist (form body)
  80         (walk/cons form env (cons form call-stack))))))
  81
  82 (defmethod walk/cons ((expr (cons multiple-value-bind)) env call-stack)
  83   (let ((lambda-list (cadr expr))
  84         (value-form (caddr expr))
  85         (body (cdddr expr)))
  86     (walk/cons value-form env (cons value-form call-stack))
  87     (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
  88       (dolist (form body)
  89         (walk/cons form env (cons form call-stack))))))
  90
  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))))))
  98
  99 ;;; walk/pattern
 100
 101 (defun walk-binding-form-body (bindings body env call-stack)
 102   (with-checked-bindings (bindings env call-stack)
 103     (dolist (form body)
 104       (walk/pattern form env (cons form call-stack)))))
 105
 106 (defgeneric walk/pattern (form env vars)
 107   (:generic-function-class pattern-generic-function))
 108
 109 (defmethod walk/pattern ((expr t) env call-stack)
 110   nil)
 111
 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)))))
 118
 119 (defmethod walk/pattern ((expr (pattern (type (and symbol (not (satisfies constantp)))))) env call-stack)
 120   (let ((binding (find-binding env expr)))
 121     (if binding
 122         (setf (used binding) t)
 123         (warn 'unbound-variable-referenced :name expr
 124               :env env :call-stack call-stack))))
 125
 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))
 129
 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))
 134
 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)))
 142
 143 ;;; walk/case
 144
 145 (defun walk/case (expr env call-stack)
 146   (typecase expr
 147     (symbol
 148      (if (constantp expr)
 149          nil
 150          (let ((binding (find-binding env expr)))
 151            (if binding
 152                (setf (used binding) t)
 153                (warn 'unbound-variable-referenced :name expr
 154                      :env env :call-stack call-stack)))))
 155     ((cons (eql lambda))
 156      (let ((lambda-list (cadr expr))
 157            (body (cddr expr)))
 158        (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
 159          (dolist (form body)
 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))
 164            (body (cdddr expr)))
 165        (walk/case value-form env (cons value-form call-stack))
 166        (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
 167          (dolist (form body)
 168            (walk/case form env (cons form call-stack))))))
 169     ((cons (eql macrolet)))
 170     ((cons (eql flet)))
 171     ((cons (eql labels)))
 172     ((cons (eql symbol-macrolet)))
 173     ((cons (eql if)))
 174     ((cons (eql progn)))
 175     ((cons (eql tagbody)))
 176     ((cons (eql return-from)))
 177     ((cons (eql multiple-value-call)))
 178     ((cons (eql block)))
 179     ((cons (eql catch)))
 180     ((cons (eql throw)))
 181     ((cons (eql let))
 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)))))
 185     (cons
 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)))))
 191     (t)))
 192
 193 ;;; walk/meth
 194
 195 (defgeneric walk/meth (expr env call-stack))
 196
 197 (defmethod walk/meth ((expr symbol) env call-stack)
 198   (if (constantp expr)
 199       nil
 200       (let ((binding (find-binding env expr)))
 201         (if binding
 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)
 206   nil)
 207
 208 (defmethod walk/meth ((expr cons) env call-stack)
 209   (typecase expr
 210     ((cons (eql lambda))
 211      (let ((lambda-list (cadr expr))
 212            (body (cddr expr)))
 213        (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
 214          (dolist (form body)
 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))
 219            (body (cdddr expr)))
 220        (walk/meth value-form env (cons value-form call-stack))
 221        (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
 222          (dolist (form body)
 223            (walk/meth form env (cons form call-stack))))))
 224     ((cons (eql macrolet)))
 225     ((cons (eql flet)))
 226     ((cons (eql labels)))
 227     ((cons (eql symbol-macrolet)))
 228     ((cons (eql if)))
 229     ((cons (eql progn)))
 230     ((cons (eql tagbody)))
 231     ((cons (eql return-from)))
 232     ((cons (eql multiple-value-call)))
 233     ((cons (eql block)))
 234     ((cons (eql catch)))
 235     ((cons (eql throw)))
 236     ((cons (eql let))
 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)))))
 240     (t
 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)))))))