From: Christophe Rhodes <csr21@cantab.net>
Date: Sun, 13 Apr 2014 19:55:15 +0000 (+0100)
Subject: rearrange repository to have src/ and examples/ directories
X-Git-Url: http://christophe.rhodes.io/gitweb/?p=specializable.git;a=commitdiff_plain;h=9dd8f1378407cae8ec7b6b05a8b3c152bc4a5f9b

rearrange repository to have src/ and examples/ directories
---

diff --git a/accept-specializer.lisp b/accept-specializer.lisp
deleted file mode 100644
index c08f537..0000000
--- a/accept-specializer.lisp
+++ /dev/null
@@ -1,268 +0,0 @@
-(in-package "SPECIALIZABLE")
-
-(defstruct accept-node
-  (name (error "missing name"))
-  (children nil)
-  (q nil))
-(defun print-accept-tree (tree stream)
-  (let (*stack*)
-    (declare (special *stack*))
-    (labels ((walk (fun node)
-               (let ((*stack* (cons node *stack*)))
-                 (declare (special *stack*))
-                 (mapc (lambda (x) (walk fun x)) (accept-node-children node)))
-               (funcall fun node))
-             (stringify (node)
-               (case (length *stack*)
-                 (0 "*/*")
-                 (1 (format nil "~A/*" (accept-node-name node)))
-                 (2 (format nil "~A/~A" (accept-node-name (car *stack*)) (accept-node-name node))))))
-      (let ((first t))
-        (walk
-         (lambda (x)
-           (let ((q (accept-node-q x)))
-             (when q
-               (format stream "~:[, ~;~]" first)
-               (format stream "~A~:[;q=~A~;~]" (stringify x) (= q 1.0) q)
-               (setf first nil))))
-         tree)))))
-(defmethod print-object ((o accept-node) s)
-  (if (accept-node-name o)
-      (call-next-method)
-      (pprint-logical-block (s nil)
-        (print-unreadable-object (o s :type t)
-          (print-accept-tree o s)))))
-
-(defun q (media-type accept-tree)
-  (let* ((pos (position #\/ media-type))
-         (type (subseq media-type 0 pos))
-         (subtype (subseq media-type (1+ pos)))
-         (type-node (find type (accept-node-children accept-tree) :key #'accept-node-name :test #'string=))
-         (subtype-node (and type-node (find subtype (accept-node-children type-node) :key #'accept-node-name :test #'string=))))
-    (or (and subtype-node (accept-node-q subtype-node))
-        (and type-node (accept-node-q type-node))
-        (accept-node-q accept-tree))))
-
-(defun q-ok (media-type accept-tree)
-  (let ((q (q media-type accept-tree)))
-    (and q (> q 0) q)))
-
-(defun insert (range q tree)
-  (labels ((ensure-node (range tree)
-             (cond
-               ((null range) tree)
-               (t (ensure-node (cdr range)
-                               (or (find (car range) (accept-node-children tree)
-                                         :key #'accept-node-name :test #'string=)
-                                   (car (push
-                                         (make-accept-node :name (car range))
-                                         (accept-node-children tree)))))))))
-    (let ((node (ensure-node range tree)))
-      ;; we could choose different behaviour here
-      (setf (accept-node-q node) q))
-    tree))
-
-(defun parse-accept-string (string)
-  (flet ((whitespacep (x)
-           (member x '(#\Space #\Tab))))
-    (let ((string (remove-if #'whitespacep string))
-          (result (make-accept-node :name nil)))
-      (cl-ppcre:do-register-groups (type subtype qp q)
-          ;; not desperately error-proof
-          ("([a-z]*|\\*)/([a-z0-9]*|\\*)(;q=([01]\\.[0-9]*))?(,|$)" string result)
-        (if qp
-            (setf q (float (+ (digit-char-p (char q 0))
-                              (/ (parse-integer q :start 2)
-                                 (expt 10 (- (length q) 2))))))
-            (setf q 1.0))
-        (let ((range (and (string/= type "*")
-                          (cons type (and (string/= subtype "*")
-                                          (list subtype))))))
-          (insert range q result))))))
-
-;;; FIXME: tiebreaker predicate (maybe defaulting to string<)?
-(defclass accept-specializer (extended-specializer)
-  ((media-type :initarg :media-type :type string :reader media-type)))
-(defmethod print-object ((o accept-specializer) s)
-  (print-unreadable-object (o s :type t)
-    (format s "~S" (media-type o))))
-;;; FIXME: would be cute to have sb-pcl:generalizer to inherit from.
-;;; Or maybe specializable:extended-generalizer could handle the NEXT
-;;; functionality?
-(defclass accept-generalizer ()
-  ((header :initarg :header :reader header)
-   (tree)
-   (next :initarg :next :reader next)))
-(defmethod print-object ((o accept-generalizer) s)
-  (print-unreadable-object (o s :type t)
-    (print-accept-tree (tree o) s)))
-(defmethod tree ((x accept-generalizer))
-  (if (slot-boundp x 'tree)
-      (slot-value x 'tree)
-      (setf (slot-value x 'tree) (parse-accept-string (header x)))))
-(defclass accept-generic-function (specializable-generic-function)
-  ()
-  (:metaclass sb-mop:funcallable-standard-class))
-
-(define-extended-specializer accept (gf arg)
-  (declare (ignore gf))
-  (make-instance 'accept-specializer :media-type arg))
-(defmethod sb-pcl:unparse-specializer-using-class
-    ((gf accept-generic-function) (specializer accept-specializer))
-  `(accept ,(media-type specializer)))
-(defmethod sb-pcl::same-specializer-p
-    ((s1 accept-specializer) (s2 accept-specializer))
-  (string= (media-type s1) (media-type s2)))
-
-(defmethod generalizer-of-using-class ((gf accept-generic-function) (arg tbnl:request))
-  (make-instance 'accept-generalizer
-                 :header (tbnl:header-in :accept arg)
-                 :next (call-next-method)))
-(defmethod generalizer-equal-hash-key
-    ((gf accept-generic-function) (g accept-generalizer))
-  `(accept-generalizer ,(header g)))
-(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) (generalizer accept-generalizer))
-  (values (q-ok (media-type s) (tree generalizer)) t))
-(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) generalizer)
-  (values nil t))
-(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s sb-mop:specializer) (generalizer accept-generalizer))
-  (specializer-accepts-generalizer-p gf s (next generalizer)))
-
-(defmethod specializer-accepts-p ((specializer accept-specializer) obj)
-  nil)
-(defmethod specializer-accepts-p ((specializer accept-specializer) (obj tbnl:request))
-  (q-ok (media-type specializer) (parse-accept-string (tbnl:header-in :accept obj))))
-
-(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 accept-specializer) generalizer)
-  (cond
-    ((string= (media-type s1) (media-type s2)) '=)
-    (t (let ((q1 (q (media-type s1) (tree generalizer)))
-             (q2 (q (media-type s2) (tree generalizer))))
-         (cond
-           ((= q1 q2) '=)
-           ((< q1 q2) '>)
-           (t '<))))))
-(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 class) generalizer)
-  '<)
-(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 sb-mop:eql-specializer) generalizer)
-  '>)
-(defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 accept-specializer) generalizer)
-  (ecase (specializer< gf s2 s1 generalizer)
-    ((>) '<)
-    ((<) '>)))
-(defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (g accept-generalizer))
-  (specializer< gf s1 s2 (next g)))
-
-(defvar *actual-content-type*)
-(defgeneric handle-content-type (x))
-(define-method-combination content-negotiation ()
-  ((around (:around))
-   (before (:before))
-   (primary () :required t)
-   (after (:after)))
-  (:arguments request)
-  (labels ((call-methods (methods)
-             (mapcar #'(lambda (method)
-                         `(call-method ,method))
-                     methods))
-           (transform (primaries)
-             (let ((method (car primaries))
-                   (nexts (cdr primaries)))
-               `(make-method
-                 (progn
-                   (let ((request-specializer (car (sb-mop:method-specializers ,method))))
-                     (when (typep request-specializer 'accept-specializer)
-                       (setf *actual-content-type* (media-type request-specializer))))
-                   (throw 'content-negotiation (call-method ,method ,@(and nexts `((,(transform nexts))))))))))
-           (wrap (form)
-             `(let ((*actual-content-type*))
-                (multiple-value-prog1
-                    ,form
-                  (handle-content-type ,request)))))
-    (let ((form (if (or before after (rest primary))
-                    `(multiple-value-prog1
-                         (progn ,@(call-methods before)
-                                (catch 'content-negotiation (call-method ,(transform primary))))
-                       ,@(call-methods (reverse after)))
-                    `(catch 'content-negotiation (call-method ,(transform primary))))))
-      (if around
-          (wrap `(call-method ,(first around)
-                              (,@(rest around) (make-method ,form))))
-          (wrap form)))))
-(define-method-combination content-negotiation/or ()
-  ((around (:around))
-   (primary () :required t))
-  (:arguments request)
-  (labels ((transform/1 (method)
-             `(make-method
-               (progn
-                 (let ((s (car (sb-mop:method-specializers ,method))))
-                   (when (typep s 'accept-specializer)
-                     (setf *actual-content-type* (media-type s))))
-                 (call-method ,method))))
-           (transform (primaries)
-             (mapcar #'(lambda (x) `(call-method ,(transform/1 x)))
-                     primaries))
-           (wrap (form)
-             `(let ((*actual-content-type*))
-                (multiple-value-prog1
-                    ,form
-                  (handle-content-type ,request)))))
-    (let ((form (if (rest primary)
-                    `(or ,@(transform primary))
-                    `(call-method ,(transform/1 (car primary))))))
-      (if around
-          (wrap `(call-method ,(first around)
-                              (,@(rest around) (make-method ,form))))
-          (wrap form)))))
-
-(defmethod generalizer-of-using-class ((gf accept-generic-function) (s string))
-  (make-instance 'accept-generalizer
-                 :header s
-                 :next (call-next-method)))
-(defmethod specializer-accepts-p ((s accept-specializer) (string string))
-  (q-ok (media-type s) (parse-accept-string string)))
-
-(defmethod handle-content-type ((x tbnl:request))
-  (setf (tbnl:content-type*) *actual-content-type*))
-(defmethod handle-content-type ((x string))
-  (format t "~&Content-Type: ~A" *actual-content-type*))
-
-(defgeneric respond (request)
-  (:generic-function-class accept-generic-function)
-  (:method-combination list))
-(defmethod respond list (request)
-  t)
-(defmethod respond list ((s string))
-  'string)
-(defmethod respond list ((s (accept "text/html")))
-  "text/html")
-(defmethod respond list ((s (accept "audio/mp3")))
-  "audio/mp3")
-
-(defgeneric cn-test (request)
-  (:generic-function-class accept-generic-function)
-  (:method-combination content-negotiation))
-(defmethod cn-test ((request (accept "text/html")))
-  'html)
-(defmethod cn-test ((request (accept "text/plain")))
-  'plain)
-(defmethod cn-test ((request (accept "image/webp")))
-  'webp)
-(defmethod cn-test ((request (accept "audio/mp3")))
-  (call-next-method)
-  'mp3)
-(defmethod cn-test :after (request)
-  (print 'after))
-
-(defgeneric cn/or-test (request)
-  (:generic-function-class accept-generic-function)
-  (:method-combination content-negotiation/or))
-
-(defmethod cn/or-test or ((request (accept "audio/mp3")))
-  'mp3)
-(defmethod cn/or-test or ((request (accept "image/webp")))
-  'webp)
-(defmethod cn/or-test :around ((request t))
-  (print :around)
-  (call-next-method))
diff --git a/cons-specializer.lisp b/cons-specializer.lisp
deleted file mode 100644
index 38be99d..0000000
--- a/cons-specializer.lisp
+++ /dev/null
@@ -1,130 +0,0 @@
-(in-package "SPECIALIZABLE")
-
-;;;; CONS-SPECIALIZER example
-(defclass cons-specializer (extended-specializer)
-  ((car :initarg :car :reader %car)))
-(defclass cons-generic-function (specializable-generic-function)
-  ()
-  (:metaclass sb-mop:funcallable-standard-class))
-
-(define-extended-specializer cons (gf car)
-  (make-instance 'cons-specializer :car car))
-(defmethod sb-pcl:unparse-specializer-using-class
-    ((gf cons-generic-function) (specializer cons-specializer))
-  `(cons ,(%car specializer)))
-(defmethod sb-pcl::same-specializer-p
-    ((s1 cons-specializer) (s2 cons-specializer))
-  (eql (%car s1) (%car s2)))
-
-;;; FIXME: make a proper generalizer
-(defmethod generalizer-equal-hash-key ((gf cons-generic-function) (g symbol))
-  g)
-(defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
-  (typecase arg
-    ((cons symbol) (car arg))
-    (t (call-next-method))))
-(defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer cons-specializer) thing)
-  (if (eql (%car specializer) thing)
-      (values t t)
-      (values nil t)))
-(defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer sb-mop:specializer) (thing symbol))
-  (specializer-accepts-generalizer-p gf specializer (find-class 'cons)))
-
-;;; note: this method operates in full knowledge of the object, and so
-;;; does not require the generic function as an argument.
-(defmethod specializer-accepts-p ((specializer cons-specializer) obj)
-  (and (consp obj)
-       (eql (car obj) (%car specializer))))
-
-(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 cons-specializer) generalizer)
-  (declare (ignore generalizer))
-  (if (eql (%car s1) (%car s2))
-      '=
-      nil))
-(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 class) generalizer)
-  (declare (ignore generalizer))
-  '<)
-(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
-  (declare (ignore generalizer))
-  '>)
-(defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
-  (ecase (specializer< gf s2 s1 generalizer)
-    ((<) '>)
-    ((>) '<)))
-;;; note: the need for this method is tricky: we need to translate
-;;; from generalizers that our specializers "know" about to those that
-;;; ordinary generic functions and specializers might know about.
-(defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (generalizer symbol))
-  (specializer< gf s1 s2 (find-class 'cons)))
-
-;;; tests / examples
-(eval
- '(progn
-   (defgeneric walk (form)
-     (:generic-function-class cons-generic-function))
-   (defmethod walk ((form symbol))
-     `(lookup ,form))
-   (defmethod walk ((form cons))
-     `(call (flookup ,(car form)) (list ,@(mapcar #'walk (cdr form)))))
-   (defmethod walk ((form (cons quote)))
-     (cadr form))
-   (defmethod walk ((form (cons let)))
-     (let ((bindings (cadr form)))
-       `(with-bindings ,bindings ,@(mapcar #'walk (cddr form)))))
-
-   (assert (equal (walk t) '(lookup t)))
-   (assert (equal (walk nil) '(lookup nil)))
-   (assert (equal (walk '(foo bar)) '(call (flookup foo) (list (lookup bar)))))
-   (assert (equal (walk '(quote bar)) 'bar))
-   (assert (equal (walk '(let foo bar)) '(with-bindings foo (lookup bar))))))
-
-(eval
- '(progn
-   (defgeneric multiple-class-specializers (x)
-     (:generic-function-class cons-generic-function)
-     (:method-combination list))
-   (defmethod multiple-class-specializers list ((x t)) 't)
-   (defmethod multiple-class-specializers list ((x cons)) 'cons)
-   (defmethod multiple-class-specializers list ((x (cons foo))) '(cons foo))
-   (defmethod multiple-class-specializers list ((x (cons bar))) '(cons bar))
-   (defmethod multiple-class-specializers list ((x list)) 'list)
-   (defmethod multiple-class-specializers list ((x null)) 'null)
-   (defmethod multiple-class-specializers list ((x (eql nil))) '(eql nil))
-
-   (assert (equal (multiple-class-specializers nil) '((eql nil) null list t)))
-   (assert (equal (multiple-class-specializers t) '(t)))
-   (assert (equal (multiple-class-specializers (cons nil nil)) '(cons list t)))
-   (assert (equal (multiple-class-specializers (cons 'foo nil)) '((cons foo) cons list t)))
-   (assert (equal (multiple-class-specializers (list 'bar nil t 3)) '((cons bar) cons list t)))))
-
-(eval
- '(progn
-   (defgeneric keyword-args (x &key key1)
-     (:generic-function-class cons-generic-function))
-   (defmethod keyword-args ((x integer) &key key1 key2) (1+ x))
-   (defmethod keyword-args ((x float) &key key1 key3) (+ x 2.0))
-   (defmethod keyword-args :after ((x double-float) &key &allow-other-keys)
-              nil)
-   (assert (= (keyword-args 1) 2))
-   (assert (= (keyword-args 1 :key1 t) 2))
-   (assert (= (keyword-args 1 :key2 t) 2))
-   (assert (= (keyword-args 1 :key1 t :key2 t) 2))
-   (assert (nth-value 1 (ignore-errors (keyword-args 1 :key1 t :key3 t))))
-   (assert (nth-value 1 (ignore-errors (keyword-args 1 :key3 t))))
-   (assert (= (keyword-args 1 :key3 t :allow-other-keys t) 2))
-
-   (assert (= (keyword-args 1.0) 3.0))
-   (assert (= (keyword-args 1.0 :key1 t) 3.0))
-   (assert (= (keyword-args 1.0 :key3 t) 3.0))
-   (assert (= (keyword-args 1.0 :key1 t :key3 t) 3.0))
-   (assert (nth-value 1 (ignore-errors (keyword-args 1.0 :key1 t :key2 t))))
-   (assert (nth-value 1 (ignore-errors (keyword-args 1.0 :key2 t))))
-   (assert (= (keyword-args 1.0 :key2 t :allow-other-keys t) 3.0))
-
-   (assert (= (keyword-args 1.0d0) 3.0d0))
-   (assert (= (keyword-args 1.0d0 :key1 t) 3.0d0))
-   (assert (= (keyword-args 1.0d0 :key3 t) 3.0d0))
-   (assert (= (keyword-args 1.0d0 :key1 t :key3 t) 3.0d0))
-   (assert (= (keyword-args 1.0d0 :key1 t :key2 t) 3.0d0))
-   (assert (= (keyword-args 1.0d0 :key2 t) 3.0d0))
-   (assert (= (keyword-args 1.0d0 :key2 t :allow-other-keys t) 3.0d0))))
diff --git a/examples/accept-specializer.lisp b/examples/accept-specializer.lisp
new file mode 100644
index 0000000..c08f537
--- /dev/null
+++ b/examples/accept-specializer.lisp
@@ -0,0 +1,268 @@
+(in-package "SPECIALIZABLE")
+
+(defstruct accept-node
+  (name (error "missing name"))
+  (children nil)
+  (q nil))
+(defun print-accept-tree (tree stream)
+  (let (*stack*)
+    (declare (special *stack*))
+    (labels ((walk (fun node)
+               (let ((*stack* (cons node *stack*)))
+                 (declare (special *stack*))
+                 (mapc (lambda (x) (walk fun x)) (accept-node-children node)))
+               (funcall fun node))
+             (stringify (node)
+               (case (length *stack*)
+                 (0 "*/*")
+                 (1 (format nil "~A/*" (accept-node-name node)))
+                 (2 (format nil "~A/~A" (accept-node-name (car *stack*)) (accept-node-name node))))))
+      (let ((first t))
+        (walk
+         (lambda (x)
+           (let ((q (accept-node-q x)))
+             (when q
+               (format stream "~:[, ~;~]" first)
+               (format stream "~A~:[;q=~A~;~]" (stringify x) (= q 1.0) q)
+               (setf first nil))))
+         tree)))))
+(defmethod print-object ((o accept-node) s)
+  (if (accept-node-name o)
+      (call-next-method)
+      (pprint-logical-block (s nil)
+        (print-unreadable-object (o s :type t)
+          (print-accept-tree o s)))))
+
+(defun q (media-type accept-tree)
+  (let* ((pos (position #\/ media-type))
+         (type (subseq media-type 0 pos))
+         (subtype (subseq media-type (1+ pos)))
+         (type-node (find type (accept-node-children accept-tree) :key #'accept-node-name :test #'string=))
+         (subtype-node (and type-node (find subtype (accept-node-children type-node) :key #'accept-node-name :test #'string=))))
+    (or (and subtype-node (accept-node-q subtype-node))
+        (and type-node (accept-node-q type-node))
+        (accept-node-q accept-tree))))
+
+(defun q-ok (media-type accept-tree)
+  (let ((q (q media-type accept-tree)))
+    (and q (> q 0) q)))
+
+(defun insert (range q tree)
+  (labels ((ensure-node (range tree)
+             (cond
+               ((null range) tree)
+               (t (ensure-node (cdr range)
+                               (or (find (car range) (accept-node-children tree)
+                                         :key #'accept-node-name :test #'string=)
+                                   (car (push
+                                         (make-accept-node :name (car range))
+                                         (accept-node-children tree)))))))))
+    (let ((node (ensure-node range tree)))
+      ;; we could choose different behaviour here
+      (setf (accept-node-q node) q))
+    tree))
+
+(defun parse-accept-string (string)
+  (flet ((whitespacep (x)
+           (member x '(#\Space #\Tab))))
+    (let ((string (remove-if #'whitespacep string))
+          (result (make-accept-node :name nil)))
+      (cl-ppcre:do-register-groups (type subtype qp q)
+          ;; not desperately error-proof
+          ("([a-z]*|\\*)/([a-z0-9]*|\\*)(;q=([01]\\.[0-9]*))?(,|$)" string result)
+        (if qp
+            (setf q (float (+ (digit-char-p (char q 0))
+                              (/ (parse-integer q :start 2)
+                                 (expt 10 (- (length q) 2))))))
+            (setf q 1.0))
+        (let ((range (and (string/= type "*")
+                          (cons type (and (string/= subtype "*")
+                                          (list subtype))))))
+          (insert range q result))))))
+
+;;; FIXME: tiebreaker predicate (maybe defaulting to string<)?
+(defclass accept-specializer (extended-specializer)
+  ((media-type :initarg :media-type :type string :reader media-type)))
+(defmethod print-object ((o accept-specializer) s)
+  (print-unreadable-object (o s :type t)
+    (format s "~S" (media-type o))))
+;;; FIXME: would be cute to have sb-pcl:generalizer to inherit from.
+;;; Or maybe specializable:extended-generalizer could handle the NEXT
+;;; functionality?
+(defclass accept-generalizer ()
+  ((header :initarg :header :reader header)
+   (tree)
+   (next :initarg :next :reader next)))
+(defmethod print-object ((o accept-generalizer) s)
+  (print-unreadable-object (o s :type t)
+    (print-accept-tree (tree o) s)))
+(defmethod tree ((x accept-generalizer))
+  (if (slot-boundp x 'tree)
+      (slot-value x 'tree)
+      (setf (slot-value x 'tree) (parse-accept-string (header x)))))
+(defclass accept-generic-function (specializable-generic-function)
+  ()
+  (:metaclass sb-mop:funcallable-standard-class))
+
+(define-extended-specializer accept (gf arg)
+  (declare (ignore gf))
+  (make-instance 'accept-specializer :media-type arg))
+(defmethod sb-pcl:unparse-specializer-using-class
+    ((gf accept-generic-function) (specializer accept-specializer))
+  `(accept ,(media-type specializer)))
+(defmethod sb-pcl::same-specializer-p
+    ((s1 accept-specializer) (s2 accept-specializer))
+  (string= (media-type s1) (media-type s2)))
+
+(defmethod generalizer-of-using-class ((gf accept-generic-function) (arg tbnl:request))
+  (make-instance 'accept-generalizer
+                 :header (tbnl:header-in :accept arg)
+                 :next (call-next-method)))
+(defmethod generalizer-equal-hash-key
+    ((gf accept-generic-function) (g accept-generalizer))
+  `(accept-generalizer ,(header g)))
+(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) (generalizer accept-generalizer))
+  (values (q-ok (media-type s) (tree generalizer)) t))
+(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) generalizer)
+  (values nil t))
+(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s sb-mop:specializer) (generalizer accept-generalizer))
+  (specializer-accepts-generalizer-p gf s (next generalizer)))
+
+(defmethod specializer-accepts-p ((specializer accept-specializer) obj)
+  nil)
+(defmethod specializer-accepts-p ((specializer accept-specializer) (obj tbnl:request))
+  (q-ok (media-type specializer) (parse-accept-string (tbnl:header-in :accept obj))))
+
+(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 accept-specializer) generalizer)
+  (cond
+    ((string= (media-type s1) (media-type s2)) '=)
+    (t (let ((q1 (q (media-type s1) (tree generalizer)))
+             (q2 (q (media-type s2) (tree generalizer))))
+         (cond
+           ((= q1 q2) '=)
+           ((< q1 q2) '>)
+           (t '<))))))
+(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 class) generalizer)
+  '<)
+(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 sb-mop:eql-specializer) generalizer)
+  '>)
+(defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 accept-specializer) generalizer)
+  (ecase (specializer< gf s2 s1 generalizer)
+    ((>) '<)
+    ((<) '>)))
+(defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (g accept-generalizer))
+  (specializer< gf s1 s2 (next g)))
+
+(defvar *actual-content-type*)
+(defgeneric handle-content-type (x))
+(define-method-combination content-negotiation ()
+  ((around (:around))
+   (before (:before))
+   (primary () :required t)
+   (after (:after)))
+  (:arguments request)
+  (labels ((call-methods (methods)
+             (mapcar #'(lambda (method)
+                         `(call-method ,method))
+                     methods))
+           (transform (primaries)
+             (let ((method (car primaries))
+                   (nexts (cdr primaries)))
+               `(make-method
+                 (progn
+                   (let ((request-specializer (car (sb-mop:method-specializers ,method))))
+                     (when (typep request-specializer 'accept-specializer)
+                       (setf *actual-content-type* (media-type request-specializer))))
+                   (throw 'content-negotiation (call-method ,method ,@(and nexts `((,(transform nexts))))))))))
+           (wrap (form)
+             `(let ((*actual-content-type*))
+                (multiple-value-prog1
+                    ,form
+                  (handle-content-type ,request)))))
+    (let ((form (if (or before after (rest primary))
+                    `(multiple-value-prog1
+                         (progn ,@(call-methods before)
+                                (catch 'content-negotiation (call-method ,(transform primary))))
+                       ,@(call-methods (reverse after)))
+                    `(catch 'content-negotiation (call-method ,(transform primary))))))
+      (if around
+          (wrap `(call-method ,(first around)
+                              (,@(rest around) (make-method ,form))))
+          (wrap form)))))
+(define-method-combination content-negotiation/or ()
+  ((around (:around))
+   (primary () :required t))
+  (:arguments request)
+  (labels ((transform/1 (method)
+             `(make-method
+               (progn
+                 (let ((s (car (sb-mop:method-specializers ,method))))
+                   (when (typep s 'accept-specializer)
+                     (setf *actual-content-type* (media-type s))))
+                 (call-method ,method))))
+           (transform (primaries)
+             (mapcar #'(lambda (x) `(call-method ,(transform/1 x)))
+                     primaries))
+           (wrap (form)
+             `(let ((*actual-content-type*))
+                (multiple-value-prog1
+                    ,form
+                  (handle-content-type ,request)))))
+    (let ((form (if (rest primary)
+                    `(or ,@(transform primary))
+                    `(call-method ,(transform/1 (car primary))))))
+      (if around
+          (wrap `(call-method ,(first around)
+                              (,@(rest around) (make-method ,form))))
+          (wrap form)))))
+
+(defmethod generalizer-of-using-class ((gf accept-generic-function) (s string))
+  (make-instance 'accept-generalizer
+                 :header s
+                 :next (call-next-method)))
+(defmethod specializer-accepts-p ((s accept-specializer) (string string))
+  (q-ok (media-type s) (parse-accept-string string)))
+
+(defmethod handle-content-type ((x tbnl:request))
+  (setf (tbnl:content-type*) *actual-content-type*))
+(defmethod handle-content-type ((x string))
+  (format t "~&Content-Type: ~A" *actual-content-type*))
+
+(defgeneric respond (request)
+  (:generic-function-class accept-generic-function)
+  (:method-combination list))
+(defmethod respond list (request)
+  t)
+(defmethod respond list ((s string))
+  'string)
+(defmethod respond list ((s (accept "text/html")))
+  "text/html")
+(defmethod respond list ((s (accept "audio/mp3")))
+  "audio/mp3")
+
+(defgeneric cn-test (request)
+  (:generic-function-class accept-generic-function)
+  (:method-combination content-negotiation))
+(defmethod cn-test ((request (accept "text/html")))
+  'html)
+(defmethod cn-test ((request (accept "text/plain")))
+  'plain)
+(defmethod cn-test ((request (accept "image/webp")))
+  'webp)
+(defmethod cn-test ((request (accept "audio/mp3")))
+  (call-next-method)
+  'mp3)
+(defmethod cn-test :after (request)
+  (print 'after))
+
+(defgeneric cn/or-test (request)
+  (:generic-function-class accept-generic-function)
+  (:method-combination content-negotiation/or))
+
+(defmethod cn/or-test or ((request (accept "audio/mp3")))
+  'mp3)
+(defmethod cn/or-test or ((request (accept "image/webp")))
+  'webp)
+(defmethod cn/or-test :around ((request t))
+  (print :around)
+  (call-next-method))
diff --git a/examples/cons-specializer.lisp b/examples/cons-specializer.lisp
new file mode 100644
index 0000000..38be99d
--- /dev/null
+++ b/examples/cons-specializer.lisp
@@ -0,0 +1,130 @@
+(in-package "SPECIALIZABLE")
+
+;;;; CONS-SPECIALIZER example
+(defclass cons-specializer (extended-specializer)
+  ((car :initarg :car :reader %car)))
+(defclass cons-generic-function (specializable-generic-function)
+  ()
+  (:metaclass sb-mop:funcallable-standard-class))
+
+(define-extended-specializer cons (gf car)
+  (make-instance 'cons-specializer :car car))
+(defmethod sb-pcl:unparse-specializer-using-class
+    ((gf cons-generic-function) (specializer cons-specializer))
+  `(cons ,(%car specializer)))
+(defmethod sb-pcl::same-specializer-p
+    ((s1 cons-specializer) (s2 cons-specializer))
+  (eql (%car s1) (%car s2)))
+
+;;; FIXME: make a proper generalizer
+(defmethod generalizer-equal-hash-key ((gf cons-generic-function) (g symbol))
+  g)
+(defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
+  (typecase arg
+    ((cons symbol) (car arg))
+    (t (call-next-method))))
+(defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer cons-specializer) thing)
+  (if (eql (%car specializer) thing)
+      (values t t)
+      (values nil t)))
+(defmethod specializer-accepts-generalizer-p ((gf cons-generic-function) (specializer sb-mop:specializer) (thing symbol))
+  (specializer-accepts-generalizer-p gf specializer (find-class 'cons)))
+
+;;; note: this method operates in full knowledge of the object, and so
+;;; does not require the generic function as an argument.
+(defmethod specializer-accepts-p ((specializer cons-specializer) obj)
+  (and (consp obj)
+       (eql (car obj) (%car specializer))))
+
+(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 cons-specializer) generalizer)
+  (declare (ignore generalizer))
+  (if (eql (%car s1) (%car s2))
+      '=
+      nil))
+(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 class) generalizer)
+  (declare (ignore generalizer))
+  '<)
+(defmethod specializer< ((gf cons-generic-function) (s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
+  (declare (ignore generalizer))
+  '>)
+(defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
+  (ecase (specializer< gf s2 s1 generalizer)
+    ((<) '>)
+    ((>) '<)))
+;;; note: the need for this method is tricky: we need to translate
+;;; from generalizers that our specializers "know" about to those that
+;;; ordinary generic functions and specializers might know about.
+(defmethod specializer< ((gf cons-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (generalizer symbol))
+  (specializer< gf s1 s2 (find-class 'cons)))
+
+;;; tests / examples
+(eval
+ '(progn
+   (defgeneric walk (form)
+     (:generic-function-class cons-generic-function))
+   (defmethod walk ((form symbol))
+     `(lookup ,form))
+   (defmethod walk ((form cons))
+     `(call (flookup ,(car form)) (list ,@(mapcar #'walk (cdr form)))))
+   (defmethod walk ((form (cons quote)))
+     (cadr form))
+   (defmethod walk ((form (cons let)))
+     (let ((bindings (cadr form)))
+       `(with-bindings ,bindings ,@(mapcar #'walk (cddr form)))))
+
+   (assert (equal (walk t) '(lookup t)))
+   (assert (equal (walk nil) '(lookup nil)))
+   (assert (equal (walk '(foo bar)) '(call (flookup foo) (list (lookup bar)))))
+   (assert (equal (walk '(quote bar)) 'bar))
+   (assert (equal (walk '(let foo bar)) '(with-bindings foo (lookup bar))))))
+
+(eval
+ '(progn
+   (defgeneric multiple-class-specializers (x)
+     (:generic-function-class cons-generic-function)
+     (:method-combination list))
+   (defmethod multiple-class-specializers list ((x t)) 't)
+   (defmethod multiple-class-specializers list ((x cons)) 'cons)
+   (defmethod multiple-class-specializers list ((x (cons foo))) '(cons foo))
+   (defmethod multiple-class-specializers list ((x (cons bar))) '(cons bar))
+   (defmethod multiple-class-specializers list ((x list)) 'list)
+   (defmethod multiple-class-specializers list ((x null)) 'null)
+   (defmethod multiple-class-specializers list ((x (eql nil))) '(eql nil))
+
+   (assert (equal (multiple-class-specializers nil) '((eql nil) null list t)))
+   (assert (equal (multiple-class-specializers t) '(t)))
+   (assert (equal (multiple-class-specializers (cons nil nil)) '(cons list t)))
+   (assert (equal (multiple-class-specializers (cons 'foo nil)) '((cons foo) cons list t)))
+   (assert (equal (multiple-class-specializers (list 'bar nil t 3)) '((cons bar) cons list t)))))
+
+(eval
+ '(progn
+   (defgeneric keyword-args (x &key key1)
+     (:generic-function-class cons-generic-function))
+   (defmethod keyword-args ((x integer) &key key1 key2) (1+ x))
+   (defmethod keyword-args ((x float) &key key1 key3) (+ x 2.0))
+   (defmethod keyword-args :after ((x double-float) &key &allow-other-keys)
+              nil)
+   (assert (= (keyword-args 1) 2))
+   (assert (= (keyword-args 1 :key1 t) 2))
+   (assert (= (keyword-args 1 :key2 t) 2))
+   (assert (= (keyword-args 1 :key1 t :key2 t) 2))
+   (assert (nth-value 1 (ignore-errors (keyword-args 1 :key1 t :key3 t))))
+   (assert (nth-value 1 (ignore-errors (keyword-args 1 :key3 t))))
+   (assert (= (keyword-args 1 :key3 t :allow-other-keys t) 2))
+
+   (assert (= (keyword-args 1.0) 3.0))
+   (assert (= (keyword-args 1.0 :key1 t) 3.0))
+   (assert (= (keyword-args 1.0 :key3 t) 3.0))
+   (assert (= (keyword-args 1.0 :key1 t :key3 t) 3.0))
+   (assert (nth-value 1 (ignore-errors (keyword-args 1.0 :key1 t :key2 t))))
+   (assert (nth-value 1 (ignore-errors (keyword-args 1.0 :key2 t))))
+   (assert (= (keyword-args 1.0 :key2 t :allow-other-keys t) 3.0))
+
+   (assert (= (keyword-args 1.0d0) 3.0d0))
+   (assert (= (keyword-args 1.0d0 :key1 t) 3.0d0))
+   (assert (= (keyword-args 1.0d0 :key3 t) 3.0d0))
+   (assert (= (keyword-args 1.0d0 :key1 t :key3 t) 3.0d0))
+   (assert (= (keyword-args 1.0d0 :key1 t :key2 t) 3.0d0))
+   (assert (= (keyword-args 1.0d0 :key2 t) 3.0d0))
+   (assert (= (keyword-args 1.0d0 :key2 t :allow-other-keys t) 3.0d0))))
diff --git a/examples/prototype-specializer.lisp b/examples/prototype-specializer.lisp
new file mode 100644
index 0000000..4a2c841
--- /dev/null
+++ b/examples/prototype-specializer.lisp
@@ -0,0 +1,197 @@
+(in-package "SPECIALIZABLE")
+
+(defclass prototype-object ()
+  (;; FIXME: we should add slots at some point
+   (delegations :initarg :delegations :accessor delegations)
+   (roles :initform (make-array 0 :adjustable t :fill-pointer t)
+          :accessor roles)
+   ;; debugging aid
+   (name)))
+(defmethod print-object ((o prototype-object) s)
+  (if (slot-boundp o 'name)
+      (format s "~S" (slot-value o 'name))
+      (print-unreadable-object (o s :type t :identity t)
+        (format s "[~{~S~^, ~}]" (delegations o)))))
+(defun add-delegation (obj del)
+  (push del (delegations obj)))
+(defun remove-delegation (obj)
+  (pop (delegations obj)))
+(defun map-delegations (fun obj)
+  (funcall fun obj)
+  ;; FIXME: should we maintain a table of visited nodes?  Should it be
+  ;; topologically sorted?  Section 5.3 in PwMD [Salzman & Aldrich]
+  ;; suggests not, at least for now
+  (mapc (lambda (o) (map-delegations fun o)) (delegations obj))
+  nil)
+(defstruct (role (:type list) (:constructor make-role (method argpos)))
+  method argpos)
+(defun add-role (obj role)
+  (let ((pos (role-argpos role))
+        (roles (roles obj)))
+    (unless (< pos (length roles))
+      (dotimes (i (- (1+ pos) (length roles)))
+        (vector-push-extend nil roles)))
+    (pushnew (role-method role) (aref roles pos))))
+(defun remove-role (obj role)
+  (let ((pos (role-argpos role)))
+    (setf (aref (roles obj) pos)
+          (remove (role-method role) (aref (roles obj) pos)))
+    (tagbody
+     start
+       (when (or (= (length (roles obj)) 0)
+                 (aref (roles obj) (1- (length (roles obj)))))
+         (go done))
+       (vector-pop (roles obj))
+       (go start)
+     done)))
+(defun map-roles (fun obj)
+  (dotimes (i (length (roles obj)))
+    (dolist (m (aref (roles obj) i))
+      (funcall fun (make-role m i)))))
+(defun find-role (role obj)
+  (when (< (role-argpos role) (length (roles obj)))
+    (find (role-method role) (aref (roles obj) (role-argpos role)))))
+(defmacro do-roles ((rvar form &optional result) &body body)
+  `(progn (map-roles (lambda (,rvar) ,@body) ,form) ,result))
+(defun clone (p)
+  (let ((result (make-instance 'prototype-object
+                               :delegations (copy-list (delegations p)))))
+    (do-roles (r p result)
+      (add-role result r))))
+
+;;; redefinition semantics are interesting.  We need the INFO here so
+;;; that we can implement specializer-accepts-p, which must be able to
+;;; lookup the particular method/argpos that the specializer
+;;; represents.  But we must also be able to redefine methods in a way
+;;; that isn't insane, which I think implies that same-specializer-p
+;;; should ignore the INFO and just use the OBJECT.
+(defclass prototype-specializer (extended-specializer)
+  ((role :accessor prototype-specializer-role)
+   (object :initarg :object :accessor prototype-specializer-object)))
+(defmethod print-object ((o prototype-specializer) s)
+  (print-unreadable-object (o s :type t :identity t)
+    (format s "~S" (prototype-specializer-object o))))
+(defmethod sb-pcl::same-specializer-p
+    ((s1 prototype-specializer) (s2 prototype-specializer))
+  (eql (prototype-specializer-object s1)
+       (prototype-specializer-object s2)))
+(defclass prototype-generic-function (specializable-generic-function)
+  ()
+  (:metaclass sb-mop:funcallable-standard-class))
+(defmethod sb-pcl:make-method-specializers-form
+    ((gf prototype-generic-function) method snames env)
+  (flet ((frob (x)
+           (typecase x
+             (sb-mop:specializer x)
+             (symbol `(make-instance 'prototype-specializer :object ,x))
+             ((cons (eql 'class)) `(find-class ',(cadr x)))
+             ((cons (eql 'eql)) `(sb-mop:intern-eql-specializer ,(cadr x)))
+             (t (error "unexpected specializer name: ~S" x)))))
+    `(list ,@(mapcar #'frob snames))))
+(defmethod sb-pcl:parse-specializer-using-class
+    ((gf prototype-generic-function) name)
+  (make-instance 'prototype-specializer :object name))
+(defmethod sb-pcl:unparse-specializer-using-class
+    ((gf prototype-generic-function) (s prototype-specializer))
+  (let ((object (prototype-specializer-object s)))
+    (if (slot-boundp object 'name)
+        (slot-value object 'name)
+        s)))
+
+(defmethod add-method :after ((gf prototype-generic-function) m)
+  (let ((ss (sb-mop:method-specializers m)))
+    (do* ((i 0 (1+ i))
+          (ss ss (cdr ss))
+          (s (car ss) (car ss)))
+         ((null ss))
+      (when (typep s 'prototype-specializer)
+        (let ((object (prototype-specializer-object s))
+              (role (make-role m i)))
+          (setf (prototype-specializer-role s) role)
+          (add-role object role))))))
+(defmethod remove-method :after ((gf prototype-generic-function) m)
+  (let ((ss (sb-mop:method-specializers m)))
+    (do* ((i 0 (1+ i))
+          (ss ss (cdr ss))
+          (s (car ss) (car ss)))
+         ((null ss))
+      (when (typep s 'prototype-specializer)
+        (let ((object (prototype-specializer-object s))
+              (role (make-role m i)))
+          (setf (prototype-specializer-role s) nil)
+          ;; this is one of the places where the semantics
+          ;; are... dodgy.  Removing the method from the generic
+          ;; function, and the role from the object, doesn't affect
+          ;; the roles in any clones.  We could potentially use the
+          ;; fact that once removed the method is no longer associated
+          ;; with a generic function?  Hm, C-A-M will not consider the
+          ;; removed method for applicability...
+          (remove-role object role))))))
+
+(defmethod generalizer-of-using-class
+    ((gf prototype-generic-function) (object prototype-object))
+  object)
+
+(defmethod specializer-accepts-generalizer-p
+    ((gf prototype-generic-function) (s prototype-specializer) object)
+  (values (specializer-accepts-p s object) t))
+
+(defmethod specializer-accepts-p ((specializer prototype-specializer) object)
+  (cond
+    ((not (typep object 'prototype-object)) nil)
+    ((eql (prototype-specializer-object specializer) /root/) t)
+    (t
+     (let ((role (prototype-specializer-role specializer)))
+       (map-delegations
+        (lambda (o)
+          (when (find-role role o)
+            (return-from specializer-accepts-p t)))
+        object)))))
+
+(defmethod specializer< ((gf prototype-generic-function) (s1 prototype-specializer) (s2 prototype-specializer) g)
+  (let ((o1 (prototype-specializer-object s1))
+        (o2 (prototype-specializer-object s2)))
+    (map-delegations
+     (lambda (o)
+       (cond
+         ((eql o o1) (return-from specializer< '<))
+         ((eql o o2) (return-from specializer< '>))))
+     g)
+    '=))
+
+(defmethod compute-applicable-methods-using-generalizers ((gf prototype-generic-function) generalizers)
+  (values nil nil))
+(defmethod generalizer-equal-hash-key ((gf prototype-generic-function) (g prototype-object))
+  g)
+
+(defmacro defpvar (name value)
+  `(let ((val ,value))
+     (setf (slot-value val 'name) ',name)
+     (defparameter ,name val)))
+
+(defpvar /root/ (make-instance 'prototype-object :delegations nil))
+(defpvar /animal/ (clone /root/))
+(defpvar /fish/ (clone /root/))
+(defpvar /shark/ (clone /root/))
+(defpvar /healthy-shark/ (clone /root/))
+(defpvar /dying-shark/ (clone /root/))
+(add-delegation /fish/ /animal/)
+(add-delegation /shark/ /animal/)
+(add-delegation /shark/ /healthy-shark/)
+(defgeneric encounter (x y)
+  (:generic-function-class prototype-generic-function))
+(defmethod encounter ((x /fish/) (y /healthy-shark/))
+  (format t "~&~A swims away~%" x))
+(defmethod encounter ((x /fish/) (y /animal/))
+  x)
+(defgeneric fight (x y)
+  (:generic-function-class prototype-generic-function))
+(defmethod fight ((x /healthy-shark/) (y /shark/))
+  (remove-delegation x)
+  (add-delegation x /dying-shark/)
+  x)
+(defmethod encounter ((x /healthy-shark/) (y /fish/))
+  (format t "~&~A swallows ~A~%" x y))
+(defmethod encounter ((x /healthy-shark/) (y /shark/))
+  (format t "~&~A fights ~A~%" x y)
+  (fight x y))
diff --git a/examples/signum-specializer.lisp b/examples/signum-specializer.lisp
new file mode 100644
index 0000000..ab7c0de
--- /dev/null
+++ b/examples/signum-specializer.lisp
@@ -0,0 +1,82 @@
+(in-package "SPECIALIZABLE")
+
+;;;; SIGNUM-SPECIALIZER example
+(defclass signum-specializer (extended-specializer)
+  ((signum :initarg :signum :reader %signum)))
+(defclass signum-generic-function (specializable-generic-function)
+  ()
+  (:metaclass sb-mop:funcallable-standard-class))
+
+(define-extended-specializer signum (gf signum)
+  (make-instance 'signum-specializer :signum signum))
+(defmethod sb-pcl:unparse-specializer-using-class
+    ((gf signum-generic-function) (specializer signum-specializer))
+  `(signum ,(%signum specializer)))
+(defmethod sb-pcl::same-specializer-p
+    ((s1 signum-specializer) (s2 signum-specializer))
+  (= (%signum s1) (%signum s2)))
+
+(defmethod generalizer-equal-hash-key ((gf signum-generic-function) (g signum-specializer))
+  (%signum g))
+(defmethod generalizer-of-using-class ((gf signum-generic-function) arg)
+  (typecase arg
+    (real (make-instance 'signum-specializer :signum (signum arg)))
+    (t (call-next-method))))
+(defmethod specializer-accepts-generalizer-p ((gf signum-generic-function) (specializer signum-specializer) (thing signum-specializer))
+  (if (= (%signum specializer) (%signum thing))
+      (values t t)
+      (values nil t)))
+(defmethod specializer-accepts-generalizer-p ((gf signum-generic-function) (specializer sb-mop:specializer) (thing signum-specializer))
+  (specializer-accepts-generalizer-p gf specializer (class-of (%signum thing))))
+
+;;; note: this method operates in full knowledge of the object, and so
+;;; does not require the generic function as an argument.
+(defmethod specializer-accepts-p ((specializer signum-specializer) obj)
+  (and (realp obj)
+       (= (signum obj) (%signum specializer))))
+
+(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 signum-specializer) generalizer)
+  (declare (ignore generalizer))
+  (if (= (%signum s1) (%signum s2))
+      '=
+      nil))
+(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 class) generalizer)
+  (declare (ignore generalizer))
+  '<)
+(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 sb-mop:eql-specializer) generalizer)
+  (declare (ignore generalizer))
+  '>)
+(defmethod specializer< ((gf signum-generic-function) (s1 sb-mop:specializer) (s2 signum-specializer) generalizer)
+  (ecase (specializer< gf s2 s1 generalizer)
+    ((<) '>)
+    ((>) '<)))
+;;; note: the need for this method is tricky: we need to translate
+;;; from generalizers that our specializers "know" about to those that
+;;; ordinary generic functions and specializers might know about.
+(defmethod specializer< ((gf signum-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (generalizer signum-specializer))
+  (specializer< gf s1 s2 (class-of (%signum generalizer))))
+
+;;; tests / examples
+(eval
+ '(progn
+   (defgeneric fact (n) (:generic-function-class signum-generic-function))
+   (defmethod fact ((n (signum 0))) 1)
+   (defmethod fact ((n (signum 1))) (* n (fact (1- n))))
+   (assert (eql (fact 6) 720))
+   (assert (eql (fact 6.0) 720.0))
+   (defmethod no-applicable-method ((gf (eql #'fact)) &rest args)
+     'gotcha)
+   (assert (eql (fact -6) 'gotcha))))
+
+(eval
+ '(progn
+   (defgeneric signum-class-specializers (x)
+     (:generic-function-class signum-generic-function)
+     (:method-combination list))
+   (defmethod signum-class-specializers list ((x float)) 'float)
+   (defmethod signum-class-specializers list ((x integer)) 'integer)
+   (defmethod signum-class-specializers list ((x (signum 1))) 1)
+   (assert (equal (signum-class-specializers 1.0) '(1 float)))
+   (assert (equal (signum-class-specializers 1) '(1 integer)))
+   (assert (equal (signum-class-specializers -1.0) '(float)))
+   (assert (equal (signum-class-specializers -1) '(integer)))))
diff --git a/examples/walker.lisp b/examples/walker.lisp
new file mode 100644
index 0000000..38484ce
--- /dev/null
+++ b/examples/walker.lisp
@@ -0,0 +1,170 @@
+(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)))))))
diff --git a/prototype-specializer.lisp b/prototype-specializer.lisp
deleted file mode 100644
index 4a2c841..0000000
--- a/prototype-specializer.lisp
+++ /dev/null
@@ -1,197 +0,0 @@
-(in-package "SPECIALIZABLE")
-
-(defclass prototype-object ()
-  (;; FIXME: we should add slots at some point
-   (delegations :initarg :delegations :accessor delegations)
-   (roles :initform (make-array 0 :adjustable t :fill-pointer t)
-          :accessor roles)
-   ;; debugging aid
-   (name)))
-(defmethod print-object ((o prototype-object) s)
-  (if (slot-boundp o 'name)
-      (format s "~S" (slot-value o 'name))
-      (print-unreadable-object (o s :type t :identity t)
-        (format s "[~{~S~^, ~}]" (delegations o)))))
-(defun add-delegation (obj del)
-  (push del (delegations obj)))
-(defun remove-delegation (obj)
-  (pop (delegations obj)))
-(defun map-delegations (fun obj)
-  (funcall fun obj)
-  ;; FIXME: should we maintain a table of visited nodes?  Should it be
-  ;; topologically sorted?  Section 5.3 in PwMD [Salzman & Aldrich]
-  ;; suggests not, at least for now
-  (mapc (lambda (o) (map-delegations fun o)) (delegations obj))
-  nil)
-(defstruct (role (:type list) (:constructor make-role (method argpos)))
-  method argpos)
-(defun add-role (obj role)
-  (let ((pos (role-argpos role))
-        (roles (roles obj)))
-    (unless (< pos (length roles))
-      (dotimes (i (- (1+ pos) (length roles)))
-        (vector-push-extend nil roles)))
-    (pushnew (role-method role) (aref roles pos))))
-(defun remove-role (obj role)
-  (let ((pos (role-argpos role)))
-    (setf (aref (roles obj) pos)
-          (remove (role-method role) (aref (roles obj) pos)))
-    (tagbody
-     start
-       (when (or (= (length (roles obj)) 0)
-                 (aref (roles obj) (1- (length (roles obj)))))
-         (go done))
-       (vector-pop (roles obj))
-       (go start)
-     done)))
-(defun map-roles (fun obj)
-  (dotimes (i (length (roles obj)))
-    (dolist (m (aref (roles obj) i))
-      (funcall fun (make-role m i)))))
-(defun find-role (role obj)
-  (when (< (role-argpos role) (length (roles obj)))
-    (find (role-method role) (aref (roles obj) (role-argpos role)))))
-(defmacro do-roles ((rvar form &optional result) &body body)
-  `(progn (map-roles (lambda (,rvar) ,@body) ,form) ,result))
-(defun clone (p)
-  (let ((result (make-instance 'prototype-object
-                               :delegations (copy-list (delegations p)))))
-    (do-roles (r p result)
-      (add-role result r))))
-
-;;; redefinition semantics are interesting.  We need the INFO here so
-;;; that we can implement specializer-accepts-p, which must be able to
-;;; lookup the particular method/argpos that the specializer
-;;; represents.  But we must also be able to redefine methods in a way
-;;; that isn't insane, which I think implies that same-specializer-p
-;;; should ignore the INFO and just use the OBJECT.
-(defclass prototype-specializer (extended-specializer)
-  ((role :accessor prototype-specializer-role)
-   (object :initarg :object :accessor prototype-specializer-object)))
-(defmethod print-object ((o prototype-specializer) s)
-  (print-unreadable-object (o s :type t :identity t)
-    (format s "~S" (prototype-specializer-object o))))
-(defmethod sb-pcl::same-specializer-p
-    ((s1 prototype-specializer) (s2 prototype-specializer))
-  (eql (prototype-specializer-object s1)
-       (prototype-specializer-object s2)))
-(defclass prototype-generic-function (specializable-generic-function)
-  ()
-  (:metaclass sb-mop:funcallable-standard-class))
-(defmethod sb-pcl:make-method-specializers-form
-    ((gf prototype-generic-function) method snames env)
-  (flet ((frob (x)
-           (typecase x
-             (sb-mop:specializer x)
-             (symbol `(make-instance 'prototype-specializer :object ,x))
-             ((cons (eql 'class)) `(find-class ',(cadr x)))
-             ((cons (eql 'eql)) `(sb-mop:intern-eql-specializer ,(cadr x)))
-             (t (error "unexpected specializer name: ~S" x)))))
-    `(list ,@(mapcar #'frob snames))))
-(defmethod sb-pcl:parse-specializer-using-class
-    ((gf prototype-generic-function) name)
-  (make-instance 'prototype-specializer :object name))
-(defmethod sb-pcl:unparse-specializer-using-class
-    ((gf prototype-generic-function) (s prototype-specializer))
-  (let ((object (prototype-specializer-object s)))
-    (if (slot-boundp object 'name)
-        (slot-value object 'name)
-        s)))
-
-(defmethod add-method :after ((gf prototype-generic-function) m)
-  (let ((ss (sb-mop:method-specializers m)))
-    (do* ((i 0 (1+ i))
-          (ss ss (cdr ss))
-          (s (car ss) (car ss)))
-         ((null ss))
-      (when (typep s 'prototype-specializer)
-        (let ((object (prototype-specializer-object s))
-              (role (make-role m i)))
-          (setf (prototype-specializer-role s) role)
-          (add-role object role))))))
-(defmethod remove-method :after ((gf prototype-generic-function) m)
-  (let ((ss (sb-mop:method-specializers m)))
-    (do* ((i 0 (1+ i))
-          (ss ss (cdr ss))
-          (s (car ss) (car ss)))
-         ((null ss))
-      (when (typep s 'prototype-specializer)
-        (let ((object (prototype-specializer-object s))
-              (role (make-role m i)))
-          (setf (prototype-specializer-role s) nil)
-          ;; this is one of the places where the semantics
-          ;; are... dodgy.  Removing the method from the generic
-          ;; function, and the role from the object, doesn't affect
-          ;; the roles in any clones.  We could potentially use the
-          ;; fact that once removed the method is no longer associated
-          ;; with a generic function?  Hm, C-A-M will not consider the
-          ;; removed method for applicability...
-          (remove-role object role))))))
-
-(defmethod generalizer-of-using-class
-    ((gf prototype-generic-function) (object prototype-object))
-  object)
-
-(defmethod specializer-accepts-generalizer-p
-    ((gf prototype-generic-function) (s prototype-specializer) object)
-  (values (specializer-accepts-p s object) t))
-
-(defmethod specializer-accepts-p ((specializer prototype-specializer) object)
-  (cond
-    ((not (typep object 'prototype-object)) nil)
-    ((eql (prototype-specializer-object specializer) /root/) t)
-    (t
-     (let ((role (prototype-specializer-role specializer)))
-       (map-delegations
-        (lambda (o)
-          (when (find-role role o)
-            (return-from specializer-accepts-p t)))
-        object)))))
-
-(defmethod specializer< ((gf prototype-generic-function) (s1 prototype-specializer) (s2 prototype-specializer) g)
-  (let ((o1 (prototype-specializer-object s1))
-        (o2 (prototype-specializer-object s2)))
-    (map-delegations
-     (lambda (o)
-       (cond
-         ((eql o o1) (return-from specializer< '<))
-         ((eql o o2) (return-from specializer< '>))))
-     g)
-    '=))
-
-(defmethod compute-applicable-methods-using-generalizers ((gf prototype-generic-function) generalizers)
-  (values nil nil))
-(defmethod generalizer-equal-hash-key ((gf prototype-generic-function) (g prototype-object))
-  g)
-
-(defmacro defpvar (name value)
-  `(let ((val ,value))
-     (setf (slot-value val 'name) ',name)
-     (defparameter ,name val)))
-
-(defpvar /root/ (make-instance 'prototype-object :delegations nil))
-(defpvar /animal/ (clone /root/))
-(defpvar /fish/ (clone /root/))
-(defpvar /shark/ (clone /root/))
-(defpvar /healthy-shark/ (clone /root/))
-(defpvar /dying-shark/ (clone /root/))
-(add-delegation /fish/ /animal/)
-(add-delegation /shark/ /animal/)
-(add-delegation /shark/ /healthy-shark/)
-(defgeneric encounter (x y)
-  (:generic-function-class prototype-generic-function))
-(defmethod encounter ((x /fish/) (y /healthy-shark/))
-  (format t "~&~A swims away~%" x))
-(defmethod encounter ((x /fish/) (y /animal/))
-  x)
-(defgeneric fight (x y)
-  (:generic-function-class prototype-generic-function))
-(defmethod fight ((x /healthy-shark/) (y /shark/))
-  (remove-delegation x)
-  (add-delegation x /dying-shark/)
-  x)
-(defmethod encounter ((x /healthy-shark/) (y /fish/))
-  (format t "~&~A swallows ~A~%" x y))
-(defmethod encounter ((x /healthy-shark/) (y /shark/))
-  (format t "~&~A fights ~A~%" x y)
-  (fight x y))
diff --git a/signum-specializer.lisp b/signum-specializer.lisp
deleted file mode 100644
index ab7c0de..0000000
--- a/signum-specializer.lisp
+++ /dev/null
@@ -1,82 +0,0 @@
-(in-package "SPECIALIZABLE")
-
-;;;; SIGNUM-SPECIALIZER example
-(defclass signum-specializer (extended-specializer)
-  ((signum :initarg :signum :reader %signum)))
-(defclass signum-generic-function (specializable-generic-function)
-  ()
-  (:metaclass sb-mop:funcallable-standard-class))
-
-(define-extended-specializer signum (gf signum)
-  (make-instance 'signum-specializer :signum signum))
-(defmethod sb-pcl:unparse-specializer-using-class
-    ((gf signum-generic-function) (specializer signum-specializer))
-  `(signum ,(%signum specializer)))
-(defmethod sb-pcl::same-specializer-p
-    ((s1 signum-specializer) (s2 signum-specializer))
-  (= (%signum s1) (%signum s2)))
-
-(defmethod generalizer-equal-hash-key ((gf signum-generic-function) (g signum-specializer))
-  (%signum g))
-(defmethod generalizer-of-using-class ((gf signum-generic-function) arg)
-  (typecase arg
-    (real (make-instance 'signum-specializer :signum (signum arg)))
-    (t (call-next-method))))
-(defmethod specializer-accepts-generalizer-p ((gf signum-generic-function) (specializer signum-specializer) (thing signum-specializer))
-  (if (= (%signum specializer) (%signum thing))
-      (values t t)
-      (values nil t)))
-(defmethod specializer-accepts-generalizer-p ((gf signum-generic-function) (specializer sb-mop:specializer) (thing signum-specializer))
-  (specializer-accepts-generalizer-p gf specializer (class-of (%signum thing))))
-
-;;; note: this method operates in full knowledge of the object, and so
-;;; does not require the generic function as an argument.
-(defmethod specializer-accepts-p ((specializer signum-specializer) obj)
-  (and (realp obj)
-       (= (signum obj) (%signum specializer))))
-
-(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 signum-specializer) generalizer)
-  (declare (ignore generalizer))
-  (if (= (%signum s1) (%signum s2))
-      '=
-      nil))
-(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 class) generalizer)
-  (declare (ignore generalizer))
-  '<)
-(defmethod specializer< ((gf signum-generic-function) (s1 signum-specializer) (s2 sb-mop:eql-specializer) generalizer)
-  (declare (ignore generalizer))
-  '>)
-(defmethod specializer< ((gf signum-generic-function) (s1 sb-mop:specializer) (s2 signum-specializer) generalizer)
-  (ecase (specializer< gf s2 s1 generalizer)
-    ((<) '>)
-    ((>) '<)))
-;;; note: the need for this method is tricky: we need to translate
-;;; from generalizers that our specializers "know" about to those that
-;;; ordinary generic functions and specializers might know about.
-(defmethod specializer< ((gf signum-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (generalizer signum-specializer))
-  (specializer< gf s1 s2 (class-of (%signum generalizer))))
-
-;;; tests / examples
-(eval
- '(progn
-   (defgeneric fact (n) (:generic-function-class signum-generic-function))
-   (defmethod fact ((n (signum 0))) 1)
-   (defmethod fact ((n (signum 1))) (* n (fact (1- n))))
-   (assert (eql (fact 6) 720))
-   (assert (eql (fact 6.0) 720.0))
-   (defmethod no-applicable-method ((gf (eql #'fact)) &rest args)
-     'gotcha)
-   (assert (eql (fact -6) 'gotcha))))
-
-(eval
- '(progn
-   (defgeneric signum-class-specializers (x)
-     (:generic-function-class signum-generic-function)
-     (:method-combination list))
-   (defmethod signum-class-specializers list ((x float)) 'float)
-   (defmethod signum-class-specializers list ((x integer)) 'integer)
-   (defmethod signum-class-specializers list ((x (signum 1))) 1)
-   (assert (equal (signum-class-specializers 1.0) '(1 float)))
-   (assert (equal (signum-class-specializers 1) '(1 integer)))
-   (assert (equal (signum-class-specializers -1.0) '(float)))
-   (assert (equal (signum-class-specializers -1) '(integer)))))
diff --git a/specializable.asd b/specializable.asd
index 94512ac..e2efeea 100644
--- a/specializable.asd
+++ b/specializable.asd
@@ -10,4 +10,5 @@
   :author      "Jan Moringen <jmoringe@techfak.uni-bielefeld.de>"
   :license     "TODO"
   :description "Generalized specializers - SBCL only"
-  :components  ((:file       "specializable")))
+  :components  ((:module "src"
+                 :components ((:file       "specializable")))))
diff --git a/specializable.lisp b/specializable.lisp
deleted file mode 100644
index 8d01319..0000000
--- a/specializable.lisp
+++ /dev/null
@@ -1,291 +0,0 @@
-;;; written by David Lichteblau, based on code by Christophe Rhodes,
-;;; Closette, and SBCL
-;;;
-;;; http://www.lichteblau.com/git/?p=specializable.git;a=blob_plain;f=specializable.lisp;hb=eb30d235951c3c1d128811278760f1db36cd336c
-
-(defpackage "SPECIALIZABLE"
-  (:use "CL" "SB-EXT")
-  (:export "SPECIALIZABLE-GENERIC-FUNCTION" "SPECIALIZABLE-METHOD"
-           "EXTENDED-SPECIALIZER"
-
-           "SPECIALIZER-ACCEPTS-P" "SPECIALIZER-ACCEPTS-GENERALIZER-P"
-           "SPECIALIZER<"
-
-           "GENERALIZER-OF-USING-CLASS"
-           "COMPUTE-APPLICABLE-METHODS-USING-GENERALIZERS"
-           "GENERALIZER-EQUAL-HASH-KEY"
-           
-           "DEFINE-EXTENDED-SPECIALIZER"))
-
-(in-package "SPECIALIZABLE")
-
-(defclass extended-specializer (sb-mop:specializer)
-  ;; FIXME: this doesn't actually do quite what I wanted.
-  ((direct-methods-table :allocation :class
-                         :initform nil :accessor direct-methods-table)))
-
-(defmethod sb-mop:add-direct-method ((specializer extended-specializer) method)
-  (let* ((table (direct-methods-table specializer))
-         (cell (assoc specializer table :test #'sb-pcl::same-specializer-p)))
-    (unless cell
-      (setf cell (cons specializer nil))
-      (push cell (direct-methods-table specializer)))
-    (push method (cdr cell))))
-
-(defmethod sb-mop:remove-direct-method ((specializer extended-specializer) method)
-  (let* ((table (direct-methods-table specializer))
-         (cell (assoc specializer table :test #'sb-pcl::same-specializer-p)))
-    (setf (cdr cell) (remove method (cdr cell)))))
-
-(defmethod sb-mop:specializer-direct-methods ((specializer extended-specializer))
-  (cdr (assoc specializer (direct-methods-table specializer)
-              :test #'sb-pcl::same-specializer-p)))
-(defmethod sb-mop:specializer-direct-generic-functions ((specializer extended-specializer))
-  (remove-duplicates (mapcar #'sb-mop:method-generic-function (sb-mop:specializer-direct-methods specializer))))
-
-(defclass specializable-generic-function (standard-generic-function)
-  ((emf-table :initform (make-hash-table :test 'equal) :reader emf-table)
-   (cacheingp :initform t :initarg :cacheingp)
-   (single-arg-cacheing-p :initform t :initarg :single-arg-cacheing-p))
-  (:metaclass sb-mop:funcallable-standard-class)
-  (:default-initargs :method-class (find-class 'specializable-method)))
-
-;;; TODO: we don't use this class yet, but we might do later
-(defclass specializable-method (standard-method) ())
-
-;;; TODO use info?
-(defun extended-specializer-name-p (name)
-  (and (symbolp name)
-       (get name 'extended-specializer-parser)))
-
-(deftype extended-specializer-name ()
-  `(satisfies extended-specializer-name-p))
-
-(defmacro define-extended-specializer (name (gf-var &rest args) &body body)
-  ;; FIXME: unparser
-  `(setf (get ',name 'extended-specializer-parser)
-         (lambda (,gf-var ,@args)
-           ,@body)))
-
-;; doesn't work, because we'd have to dump GF into the fasl for the macro
-;; expansion
-;;; (defun intern-extended-specializer (gf sname)
-;;;   (destructuring-bind (kind &rest args) sname
-;;;     (setf (gethash sname (generic-function-extended-specializers gf))
-;;; 	  (apply (or (get kind 'extended-specializer-parser)
-;;; 		     (error "not declared as an extended specializer name: ~A"
-;;; 			    kind))
-;;; 		 gf
-;;; 		 args))))
-
-(defun make-extended-specializer (sname)
-  (destructuring-bind (kind &rest args) sname
-    (apply (or (get kind 'extended-specializer-parser)
-	       (error "not declared as an extended specializer name: ~A"
-		      kind))
-	   '|This is not a generic function| ;fixme, see comment above
-	   args)))
-
-;;; from SBCL:
-
-(defmethod sb-pcl:parse-specializer-using-class
-    ((gf specializable-generic-function) (specializer-name t))
-  (if (typep specializer-name '(cons extended-specializer-name))
-      (make-extended-specializer specializer-name)
-      (call-next-method)))
-
-(defmethod sb-pcl:make-method-specializers-form
-    ((gf specializable-generic-function) method snames env)
-  (declare (ignore method env))
-  (flet ((parse (name)
-           (cond
-             ((typep name 'sb-mop:specializer) name)
-             ((symbolp name) `(find-class ',name))
-             ((consp name)
-	      (case (car name)
-		(eql `(sb-mop:intern-eql-specializer ,(cadr name)))
-		(t `(make-extended-specializer ',name))))
-             (t (error "unexpected specializer name")))))
-    `(list ,@(mapcar #'parse snames))))
-
-;;; from Closette, changed to use some SBCL functions:
-
-;;; FIXME: this is not actually sufficient argument checking
-(defun required-portion (gf args)
-  (let ((number-required
-	 (sb-pcl::arg-info-number-required (sb-pcl::gf-arg-info gf))))
-    (when (< (length args) number-required)
-      (error "Too few arguments to generic function ~S." gf))
-    (subseq args 0 number-required)))
-
-(defgeneric generalizer-equal-hash-key (generic-function generalizer))
-(defmethod generalizer-equal-hash-key
-    ((gf specializable-generic-function) (g class))
-  (sb-pcl::class-wrapper g))
-
-(defun first-arg-only-special-case (gf)
-  (let ((arg-info (sb-pcl::gf-arg-info gf)))
-    (and (slot-value gf 'single-arg-cacheing-p)
-         (>= (sb-pcl::arg-info-number-required arg-info) 1)
-         (every (lambda (x) (eql x t))
-                (cdr (sb-pcl::arg-info-metatypes arg-info))))))
-
-;;; FIXME: in some kind of order, the discriminating function needs to handle:
-;;; - argument count checking;
-;;; - DONE (in effective method) keyword argument validity;
-;;; - DONE flushing the emf cache on method addition/removal
-;;; - DONE (sort of, using wrappers/g-e-h-k) flushing the cache on class redefinition;
-;;; - cache thread-safety.
-;;; - speed
-;;; - DONE (in SBCL itself) interaction with TRACE et al.
-(defmethod sb-mop:compute-discriminating-function ((gf specializable-generic-function))
-  (cond
-    ((not (slot-value gf 'cacheingp))
-     (lambda (&rest args)
-       (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
-                                   args)))
-         (slow-method-lookup-and-call gf args generalizers))))
-    ((first-arg-only-special-case gf)
-     (lambda (&rest args)
-       (let* ((g (generalizer-of-using-class gf (car args)))
-              (k (generalizer-equal-hash-key gf g))
-              (emfun (gethash k (emf-table gf) nil)))
-         (if emfun
-             (sb-pcl::invoke-emf emfun args)
-             (slow-method-lookup-and-call
-              gf args (cons g (mapcar (lambda (x) (generalizer-of-using-class gf x))
-                                      (cdr (required-portion gf args)))))))))
-    (t
-     (lambda (&rest args)
-       (let* ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
-                                    (required-portion gf args)))
-              (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers))
-              (emfun (gethash keys (emf-table gf) nil)))
-         (if emfun
-             (sb-pcl::invoke-emf emfun args)
-             (slow-method-lookup-and-call gf args generalizers)))))))
-
-(defmethod reinitialize-instance :after ((gf specializable-generic-function) &key)
-  (clrhash (emf-table gf)))
-
-(defun slow-method-lookup (gf args generalizers)
-  (multiple-value-bind (applicable-methods definitivep)
-      (compute-applicable-methods-using-generalizers gf generalizers)
-    (unless definitivep
-      (setf applicable-methods (compute-applicable-methods gf args)))
-    (values (compute-effective-method-function gf applicable-methods)
-            definitivep)))
-
-(defun slow-method-lookup-and-call (gf args generalizers)
-  (multiple-value-bind (emf cacheablep)
-      (slow-method-lookup gf args generalizers)
-    (when cacheablep
-      (let ((keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers)))
-        (if (first-arg-only-special-case gf)
-            (setf (gethash (car keys) (emf-table gf)) emf)
-            (setf (gethash keys (emf-table gf)) emf))))
-    (sb-pcl::invoke-emf emf args)))
-
-(defun compute-effective-method-function (gf methods)
-  (if (null methods)
-      (lambda (&rest args) (apply #'no-applicable-method gf args))
-      (let* ((mc (sb-mop:generic-function-method-combination gf))
-             (sb-pcl::*applicable-methods* methods)
-             (em (sb-mop:compute-effective-method gf mc methods)))
-        (sb-pcl::make-effective-method-function gf em))))
-
-;; new, not in closette
-(defgeneric generalizer-of-using-class (generic-function object))
-(defmethod generalizer-of-using-class ((generic-function specializable-generic-function) object)
-  (class-of object))
-
-(defgeneric specializer-accepts-generalizer-p (gf specializer generalizer))
-(defmethod specializer-accepts-generalizer-p
-    ((gf specializable-generic-function) (specializer class) (generalizer class))
-  (if (subtypep generalizer specializer)
-      (values t t)
-      (values nil t)))
-(defmethod specializer-accepts-generalizer-p
-    ((gf specializable-generic-function) (specializer sb-mop:eql-specializer) (generalizer class))
-  (if (eq generalizer (class-of (sb-mop:eql-specializer-object specializer)))
-      (values t nil)
-      (values nil t)))
-
-(defgeneric compute-applicable-methods-using-generalizers (gf generalizers))
-(defmethod compute-applicable-methods-using-generalizers
-    ((gf specializable-generic-function) generalizers)
-  ;; differs from closette
-  (let ((result-definitive-p t))
-    (flet ((filter (method)
-             (every (lambda (s g)
-                      (multiple-value-bind (acceptsp definitivep)
-                          (specializer-accepts-generalizer-p gf s g)
-                        (unless definitivep
-                          (setf result-definitive-p nil))
-                        acceptsp))
-                    (sb-mop:method-specializers method) generalizers))
-           (sorter (m1 m2)
-             (method-more-specific-p gf m1 m2 generalizers)))
-      (values
-       (sort
-        (copy-list (remove-if-not #'filter (sb-mop:generic-function-methods gf)))
-        #'sorter)
-       result-definitive-p))))
-
-;; new, not in closette
-(defgeneric specializer-accepts-p (specializer object))
-(defmethod specializer-accepts-p ((specializer class) object)
-  (typep object specializer))
-(defmethod specializer-accepts-p ((specializer sb-mop:eql-specializer) object)
-  (eq object (sb-mop:eql-specializer-object specializer)))
-
-(defmethod compute-applicable-methods
-    ((gf specializable-generic-function) arguments)
-  ;; new, not in closette
-  (sort
-   (copy-list
-    (remove-if-not #'(lambda (method)
-		       (every #'specializer-accepts-p
-			      (sb-mop:method-specializers method)
-			      arguments))
-		   (sb-mop:generic-function-methods gf)))
-   (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
-                               (required-portion gf arguments))))
-     (lambda (m1 m2)
-       (method-more-specific-p gf m1 m2 generalizers)))))
-
-(defun method-more-specific-p (gf method1 method2 generalizers)
-  ;; FIXME: argument precedence order
-  (block nil
-    (mapc #'(lambda (spec1 spec2 generalizer)
-	      (ecase (specializer< gf spec1 spec2 generalizer)
-		(< (return t))
-		(=)
-		((nil > /=) (return nil))))
-	  (sb-mop:method-specializers method1)
-	  (sb-mop:method-specializers method2)
-	  generalizers)
-    nil))
-
-;; new, not in closette
-(defgeneric specializer< (gf s1 s2 generalizer))
-(defmethod specializer<
-    ((gf specializable-generic-function) (s1 class) (s2 class) (generalizer class))
-  (if (eq s1 s2)
-      '=
-      (let ((cpl (sb-mop:class-precedence-list generalizer)))
-	(if (find s2 (cdr (member s1 cpl)))
-	    '<
-            '>))))
-(defmethod specializer<
-    ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 sb-mop:eql-specializer) generalizer)
-  (declare (ignore generalizer))
-  (if (eq (sb-mop:eql-specializer-object s1) (sb-mop:eql-specializer-object s2))
-      '=
-      nil))
-(defmethod specializer< ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 class) generalizer)
-  (declare (ignore generalizer))
-  '<)
-(defmethod specializer< ((gf specializable-generic-function) (c1 class) (c2 sb-mop:eql-specializer) generalizer)
-  (declare (ignore generalizer))
-  '>)
diff --git a/src/specializable.lisp b/src/specializable.lisp
new file mode 100644
index 0000000..8d01319
--- /dev/null
+++ b/src/specializable.lisp
@@ -0,0 +1,291 @@
+;;; written by David Lichteblau, based on code by Christophe Rhodes,
+;;; Closette, and SBCL
+;;;
+;;; http://www.lichteblau.com/git/?p=specializable.git;a=blob_plain;f=specializable.lisp;hb=eb30d235951c3c1d128811278760f1db36cd336c
+
+(defpackage "SPECIALIZABLE"
+  (:use "CL" "SB-EXT")
+  (:export "SPECIALIZABLE-GENERIC-FUNCTION" "SPECIALIZABLE-METHOD"
+           "EXTENDED-SPECIALIZER"
+
+           "SPECIALIZER-ACCEPTS-P" "SPECIALIZER-ACCEPTS-GENERALIZER-P"
+           "SPECIALIZER<"
+
+           "GENERALIZER-OF-USING-CLASS"
+           "COMPUTE-APPLICABLE-METHODS-USING-GENERALIZERS"
+           "GENERALIZER-EQUAL-HASH-KEY"
+           
+           "DEFINE-EXTENDED-SPECIALIZER"))
+
+(in-package "SPECIALIZABLE")
+
+(defclass extended-specializer (sb-mop:specializer)
+  ;; FIXME: this doesn't actually do quite what I wanted.
+  ((direct-methods-table :allocation :class
+                         :initform nil :accessor direct-methods-table)))
+
+(defmethod sb-mop:add-direct-method ((specializer extended-specializer) method)
+  (let* ((table (direct-methods-table specializer))
+         (cell (assoc specializer table :test #'sb-pcl::same-specializer-p)))
+    (unless cell
+      (setf cell (cons specializer nil))
+      (push cell (direct-methods-table specializer)))
+    (push method (cdr cell))))
+
+(defmethod sb-mop:remove-direct-method ((specializer extended-specializer) method)
+  (let* ((table (direct-methods-table specializer))
+         (cell (assoc specializer table :test #'sb-pcl::same-specializer-p)))
+    (setf (cdr cell) (remove method (cdr cell)))))
+
+(defmethod sb-mop:specializer-direct-methods ((specializer extended-specializer))
+  (cdr (assoc specializer (direct-methods-table specializer)
+              :test #'sb-pcl::same-specializer-p)))
+(defmethod sb-mop:specializer-direct-generic-functions ((specializer extended-specializer))
+  (remove-duplicates (mapcar #'sb-mop:method-generic-function (sb-mop:specializer-direct-methods specializer))))
+
+(defclass specializable-generic-function (standard-generic-function)
+  ((emf-table :initform (make-hash-table :test 'equal) :reader emf-table)
+   (cacheingp :initform t :initarg :cacheingp)
+   (single-arg-cacheing-p :initform t :initarg :single-arg-cacheing-p))
+  (:metaclass sb-mop:funcallable-standard-class)
+  (:default-initargs :method-class (find-class 'specializable-method)))
+
+;;; TODO: we don't use this class yet, but we might do later
+(defclass specializable-method (standard-method) ())
+
+;;; TODO use info?
+(defun extended-specializer-name-p (name)
+  (and (symbolp name)
+       (get name 'extended-specializer-parser)))
+
+(deftype extended-specializer-name ()
+  `(satisfies extended-specializer-name-p))
+
+(defmacro define-extended-specializer (name (gf-var &rest args) &body body)
+  ;; FIXME: unparser
+  `(setf (get ',name 'extended-specializer-parser)
+         (lambda (,gf-var ,@args)
+           ,@body)))
+
+;; doesn't work, because we'd have to dump GF into the fasl for the macro
+;; expansion
+;;; (defun intern-extended-specializer (gf sname)
+;;;   (destructuring-bind (kind &rest args) sname
+;;;     (setf (gethash sname (generic-function-extended-specializers gf))
+;;; 	  (apply (or (get kind 'extended-specializer-parser)
+;;; 		     (error "not declared as an extended specializer name: ~A"
+;;; 			    kind))
+;;; 		 gf
+;;; 		 args))))
+
+(defun make-extended-specializer (sname)
+  (destructuring-bind (kind &rest args) sname
+    (apply (or (get kind 'extended-specializer-parser)
+	       (error "not declared as an extended specializer name: ~A"
+		      kind))
+	   '|This is not a generic function| ;fixme, see comment above
+	   args)))
+
+;;; from SBCL:
+
+(defmethod sb-pcl:parse-specializer-using-class
+    ((gf specializable-generic-function) (specializer-name t))
+  (if (typep specializer-name '(cons extended-specializer-name))
+      (make-extended-specializer specializer-name)
+      (call-next-method)))
+
+(defmethod sb-pcl:make-method-specializers-form
+    ((gf specializable-generic-function) method snames env)
+  (declare (ignore method env))
+  (flet ((parse (name)
+           (cond
+             ((typep name 'sb-mop:specializer) name)
+             ((symbolp name) `(find-class ',name))
+             ((consp name)
+	      (case (car name)
+		(eql `(sb-mop:intern-eql-specializer ,(cadr name)))
+		(t `(make-extended-specializer ',name))))
+             (t (error "unexpected specializer name")))))
+    `(list ,@(mapcar #'parse snames))))
+
+;;; from Closette, changed to use some SBCL functions:
+
+;;; FIXME: this is not actually sufficient argument checking
+(defun required-portion (gf args)
+  (let ((number-required
+	 (sb-pcl::arg-info-number-required (sb-pcl::gf-arg-info gf))))
+    (when (< (length args) number-required)
+      (error "Too few arguments to generic function ~S." gf))
+    (subseq args 0 number-required)))
+
+(defgeneric generalizer-equal-hash-key (generic-function generalizer))
+(defmethod generalizer-equal-hash-key
+    ((gf specializable-generic-function) (g class))
+  (sb-pcl::class-wrapper g))
+
+(defun first-arg-only-special-case (gf)
+  (let ((arg-info (sb-pcl::gf-arg-info gf)))
+    (and (slot-value gf 'single-arg-cacheing-p)
+         (>= (sb-pcl::arg-info-number-required arg-info) 1)
+         (every (lambda (x) (eql x t))
+                (cdr (sb-pcl::arg-info-metatypes arg-info))))))
+
+;;; FIXME: in some kind of order, the discriminating function needs to handle:
+;;; - argument count checking;
+;;; - DONE (in effective method) keyword argument validity;
+;;; - DONE flushing the emf cache on method addition/removal
+;;; - DONE (sort of, using wrappers/g-e-h-k) flushing the cache on class redefinition;
+;;; - cache thread-safety.
+;;; - speed
+;;; - DONE (in SBCL itself) interaction with TRACE et al.
+(defmethod sb-mop:compute-discriminating-function ((gf specializable-generic-function))
+  (cond
+    ((not (slot-value gf 'cacheingp))
+     (lambda (&rest args)
+       (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
+                                   args)))
+         (slow-method-lookup-and-call gf args generalizers))))
+    ((first-arg-only-special-case gf)
+     (lambda (&rest args)
+       (let* ((g (generalizer-of-using-class gf (car args)))
+              (k (generalizer-equal-hash-key gf g))
+              (emfun (gethash k (emf-table gf) nil)))
+         (if emfun
+             (sb-pcl::invoke-emf emfun args)
+             (slow-method-lookup-and-call
+              gf args (cons g (mapcar (lambda (x) (generalizer-of-using-class gf x))
+                                      (cdr (required-portion gf args)))))))))
+    (t
+     (lambda (&rest args)
+       (let* ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
+                                    (required-portion gf args)))
+              (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers))
+              (emfun (gethash keys (emf-table gf) nil)))
+         (if emfun
+             (sb-pcl::invoke-emf emfun args)
+             (slow-method-lookup-and-call gf args generalizers)))))))
+
+(defmethod reinitialize-instance :after ((gf specializable-generic-function) &key)
+  (clrhash (emf-table gf)))
+
+(defun slow-method-lookup (gf args generalizers)
+  (multiple-value-bind (applicable-methods definitivep)
+      (compute-applicable-methods-using-generalizers gf generalizers)
+    (unless definitivep
+      (setf applicable-methods (compute-applicable-methods gf args)))
+    (values (compute-effective-method-function gf applicable-methods)
+            definitivep)))
+
+(defun slow-method-lookup-and-call (gf args generalizers)
+  (multiple-value-bind (emf cacheablep)
+      (slow-method-lookup gf args generalizers)
+    (when cacheablep
+      (let ((keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers)))
+        (if (first-arg-only-special-case gf)
+            (setf (gethash (car keys) (emf-table gf)) emf)
+            (setf (gethash keys (emf-table gf)) emf))))
+    (sb-pcl::invoke-emf emf args)))
+
+(defun compute-effective-method-function (gf methods)
+  (if (null methods)
+      (lambda (&rest args) (apply #'no-applicable-method gf args))
+      (let* ((mc (sb-mop:generic-function-method-combination gf))
+             (sb-pcl::*applicable-methods* methods)
+             (em (sb-mop:compute-effective-method gf mc methods)))
+        (sb-pcl::make-effective-method-function gf em))))
+
+;; new, not in closette
+(defgeneric generalizer-of-using-class (generic-function object))
+(defmethod generalizer-of-using-class ((generic-function specializable-generic-function) object)
+  (class-of object))
+
+(defgeneric specializer-accepts-generalizer-p (gf specializer generalizer))
+(defmethod specializer-accepts-generalizer-p
+    ((gf specializable-generic-function) (specializer class) (generalizer class))
+  (if (subtypep generalizer specializer)
+      (values t t)
+      (values nil t)))
+(defmethod specializer-accepts-generalizer-p
+    ((gf specializable-generic-function) (specializer sb-mop:eql-specializer) (generalizer class))
+  (if (eq generalizer (class-of (sb-mop:eql-specializer-object specializer)))
+      (values t nil)
+      (values nil t)))
+
+(defgeneric compute-applicable-methods-using-generalizers (gf generalizers))
+(defmethod compute-applicable-methods-using-generalizers
+    ((gf specializable-generic-function) generalizers)
+  ;; differs from closette
+  (let ((result-definitive-p t))
+    (flet ((filter (method)
+             (every (lambda (s g)
+                      (multiple-value-bind (acceptsp definitivep)
+                          (specializer-accepts-generalizer-p gf s g)
+                        (unless definitivep
+                          (setf result-definitive-p nil))
+                        acceptsp))
+                    (sb-mop:method-specializers method) generalizers))
+           (sorter (m1 m2)
+             (method-more-specific-p gf m1 m2 generalizers)))
+      (values
+       (sort
+        (copy-list (remove-if-not #'filter (sb-mop:generic-function-methods gf)))
+        #'sorter)
+       result-definitive-p))))
+
+;; new, not in closette
+(defgeneric specializer-accepts-p (specializer object))
+(defmethod specializer-accepts-p ((specializer class) object)
+  (typep object specializer))
+(defmethod specializer-accepts-p ((specializer sb-mop:eql-specializer) object)
+  (eq object (sb-mop:eql-specializer-object specializer)))
+
+(defmethod compute-applicable-methods
+    ((gf specializable-generic-function) arguments)
+  ;; new, not in closette
+  (sort
+   (copy-list
+    (remove-if-not #'(lambda (method)
+		       (every #'specializer-accepts-p
+			      (sb-mop:method-specializers method)
+			      arguments))
+		   (sb-mop:generic-function-methods gf)))
+   (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
+                               (required-portion gf arguments))))
+     (lambda (m1 m2)
+       (method-more-specific-p gf m1 m2 generalizers)))))
+
+(defun method-more-specific-p (gf method1 method2 generalizers)
+  ;; FIXME: argument precedence order
+  (block nil
+    (mapc #'(lambda (spec1 spec2 generalizer)
+	      (ecase (specializer< gf spec1 spec2 generalizer)
+		(< (return t))
+		(=)
+		((nil > /=) (return nil))))
+	  (sb-mop:method-specializers method1)
+	  (sb-mop:method-specializers method2)
+	  generalizers)
+    nil))
+
+;; new, not in closette
+(defgeneric specializer< (gf s1 s2 generalizer))
+(defmethod specializer<
+    ((gf specializable-generic-function) (s1 class) (s2 class) (generalizer class))
+  (if (eq s1 s2)
+      '=
+      (let ((cpl (sb-mop:class-precedence-list generalizer)))
+	(if (find s2 (cdr (member s1 cpl)))
+	    '<
+            '>))))
+(defmethod specializer<
+    ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 sb-mop:eql-specializer) generalizer)
+  (declare (ignore generalizer))
+  (if (eq (sb-mop:eql-specializer-object s1) (sb-mop:eql-specializer-object s2))
+      '=
+      nil))
+(defmethod specializer< ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 class) generalizer)
+  (declare (ignore generalizer))
+  '<)
+(defmethod specializer< ((gf specializable-generic-function) (c1 class) (c2 sb-mop:eql-specializer) generalizer)
+  (declare (ignore generalizer))
+  '>)
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)))))))