X-Git-Url: http://christophe.rhodes.io/gitweb/?p=specializable.git;a=blobdiff_plain;f=walker.lisp;fp=walker.lisp;h=0000000000000000000000000000000000000000;hp=38484ce7e36e24f773931e0fbfa4683f890febdc;hb=9dd8f1378407cae8ec7b6b05a8b3c152bc4a5f9b;hpb=d55ebbbcbd77023c799d8d95dce5d3772aec5841

diff --git a/walker.lisp b/walker.lisp
deleted file mode 100644
index 38484ce..0000000
--- a/walker.lisp
+++ /dev/null
@@ -1,170 +0,0 @@
-(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)
-  (flet ((let-binding (x)
-           (walk (cadr x) env (cons (cadr x) call-stack))
-           (cons (car x) (make-instance 'binding))))
-    (with-checked-bindings ((mapcar #'let-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)))))))