From: Christophe Rhodes <csr21@cantab.net>
Date: Sat, 22 Feb 2014 20:52:43 +0000 (+0000)
Subject: distinct walker which actually does something
X-Git-Tag: els2014-submission~9
X-Git-Url: http://christophe.rhodes.io/gitweb/?a=commitdiff_plain;h=ede4ac2bb5969bbb8a671106368e77acb5a085ac;p=specializable.git

distinct walker which actually does something

for benchmarking purposes
---

diff --git a/walker.lisp b/walker.lisp
new file mode 100644
index 0000000..6e75518
--- /dev/null
+++ b/walker.lisp
@@ -0,0 +1,167 @@
+(in-package "SPECIALIZABLE")
+
+(defclass binding ()
+  ((used :initform nil :accessor used)))
+
+(defun make-env (bindings env)
+  (append bindings env))
+(defun find-binding (env var)
+  (cdr (assoc var env)))
+
+(defun bindings-from-ll (ll)
+  (mapcar (lambda (n) (cons n (make-instance 'binding))) ll))
+
+(define-condition walker-warning (warning)
+  ((env :initarg :env :reader env)
+   (call-stack :initarg :call-stack :reader call-stack)))
+(define-condition unused-variable (walker-warning)
+  ((name :initarg :name :reader name)))
+(define-condition unbound-variable-referenced (walker-warning)
+  ((name :initarg :name :reader name)))
+
+(fmakunbound 'walk)
+(defgeneric walk (form env vars)
+  (:generic-function-class cons-generic-function))
+
+(defmethod walk ((expr cons) env call-stack)
+  (let ((cs (cons expr call-stack)))
+    (when (consp (car expr))
+      (walk (car expr) env cs))
+    (dolist (e (cdr expr))
+      (walk e env (cons e cs)))))
+(defmethod walk ((expr symbol) env call-stack)
+  (if (constantp expr)
+      nil
+      (let ((binding (find-binding env expr)))
+        (if binding
+            (setf (used binding) t)
+            (warn 'unbound-variable-referenced :name expr
+                  :env env :call-stack call-stack)))))
+(defmethod walk ((expr t) env call-stack)
+  nil)
+(defmacro with-checked-bindings ((bindings env call-stack) &body body)
+  `(let* ((bindings ,bindings)
+          (,env (make-env bindings ,env)))
+     ,@body
+     (dolist (binding bindings)
+       (unless (used (cdr binding))
+         (warn 'unused-variable :name (car binding)
+               :env ,env :call-stack ,call-stack)))))
+(defmethod walk ((expr (cons lambda)) env call-stack)
+  (let ((lambda-list (cadr expr))
+        (body (cddr expr)))
+    (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+      (dolist (form body)
+        (walk form env (cons form call-stack))))))
+(defmethod walk ((expr (cons multiple-value-bind)) env call-stack)
+  (let ((lambda-list (cadr expr))
+        (value-form (caddr expr))
+        (body (cdddr expr)))
+    (walk value-form env (cons value-form call-stack))
+    (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+      (dolist (form body)
+        (walk form env (cons form call-stack))))))
+(defmethod walk ((expr (cons let)) env call-stack)
+  (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)
+    (dolist (form (cddr expr))
+      (walk form env (cons form call-stack)))))
+
+(defun walk/case (expr env call-stack)
+  (typecase expr
+    (symbol
+     (if (constantp expr)
+         nil
+         (let ((binding (find-binding env expr)))
+           (if binding
+               (setf (used binding) t)
+               (warn 'unbound-variable-referenced :name expr
+                     :env env :call-stack call-stack)))))
+    ((cons (eql lambda))
+     (let ((lambda-list (cadr expr))
+           (body (cddr expr)))
+       (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+         (dolist (form body)
+           (walk/case form env (cons form call-stack))))))
+    ((cons (eql multiple-value-bind))
+     (let ((lambda-list (cadr expr))
+           (value-form (caddr expr))
+           (body (cdddr expr)))
+       (walk/case value-form env (cons value-form call-stack))
+       (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+         (dolist (form body)
+           (walk/case form env (cons form call-stack))))))
+    ((cons (eql macrolet)))
+    ((cons (eql flet)))
+    ((cons (eql labels)))
+    ((cons (eql symbol-macrolet)))
+    ((cons (eql if)))
+    ((cons (eql progn)))
+    ((cons (eql tagbody)))
+    ((cons (eql return-from)))
+    ((cons (eql multiple-value-call)))
+    ((cons (eql block)))
+    ((cons (eql catch)))
+    ((cons (eql throw)))
+    ((cons (eql let))
+     (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)
+       (dolist (form (cddr expr))
+         (walk/case form env (cons form call-stack)))))
+    (cons
+     (let ((cs (cons expr call-stack)))
+       (when (consp (car expr))
+         (walk/case (car expr) env cs))
+       (dolist (e (cdr expr))
+         (walk/case e env (cons e cs)))))
+    (t)))
+
+(defgeneric walk/meth (expr env call-stack))
+
+(defmethod walk/meth ((expr symbol) env call-stack)
+  (if (constantp expr)
+         nil
+         (let ((binding (find-binding env expr)))
+           (if binding
+               (setf (used binding) t)
+               (warn 'unbound-variable-referenced :name expr
+                     :env env :call-stack call-stack)))))
+(defmethod walk/meth ((expr t) env call-stack)
+  nil)
+
+(defmethod walk/meth ((expr cons) env call-stack)
+  (typecase expr
+    ((cons (eql lambda))
+     (let ((lambda-list (cadr expr))
+           (body (cddr expr)))
+       (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+         (dolist (form body)
+           (walk/meth form env (cons form call-stack))))))
+    ((cons (eql multiple-value-bind))
+     (let ((lambda-list (cadr expr))
+           (value-form (caddr expr))
+           (body (cdddr expr)))
+       (walk/meth value-form env (cons value-form call-stack))
+       (with-checked-bindings ((bindings-from-ll lambda-list) env call-stack)
+         (dolist (form body)
+           (walk/meth form env (cons form call-stack))))))
+    ((cons (eql macrolet)))
+    ((cons (eql flet)))
+    ((cons (eql labels)))
+    ((cons (eql symbol-macrolet)))
+    ((cons (eql if)))
+    ((cons (eql progn)))
+    ((cons (eql tagbody)))
+    ((cons (eql return-from)))
+    ((cons (eql multiple-value-call)))
+    ((cons (eql block)))
+    ((cons (eql catch)))
+    ((cons (eql throw)))
+    ((cons (eql let))
+     (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)
+       (dolist (form (cddr expr))
+         (walk/meth form env (cons form call-stack)))))
+    (t
+     (let ((cs (cons expr call-stack)))
+       (when (consp (car expr))
+         (walk/meth (car expr) env cs))
+       (dolist (e (cdr expr))
+         (walk/meth e env (cons e cs)))))))