From e1e0b8430d014241bdd7658b9795fae56c20b49a Mon Sep 17 00:00:00 2001
From: Christophe Rhodes <csr21@cantab.net>
Date: Wed, 11 Dec 2013 10:21:56 +0000
Subject: [PATCH] separate out cons-specializer and walk into their own file

---
 cons-specializer.lisp | 67 +++++++++++++++++++++++++++++++++++++++++++
 specializable.lisp    | 63 ----------------------------------------
 2 files changed, 67 insertions(+), 63 deletions(-)
 create mode 100644 cons-specializer.lisp

diff --git a/cons-specializer.lisp b/cons-specializer.lisp
new file mode 100644
index 0000000..70529d4
--- /dev/null
+++ b/cons-specializer.lisp
@@ -0,0 +1,67 @@
+;;;; 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)))
+
+(defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
+  (typecase arg
+    ((cons symbol) (car arg))
+    (t (call-next-method))))
+;;; FIXME: it looks like these protocol functions should have the GF
+;;; as an argument, since generalizer-of-using-class does
+(defmethod specializer-accepts-generalizer-p ((specializer cons-specializer) thing)
+  (if (eql (%car specializer) thing)
+      (values t t)
+      (values nil t)))
+;;; FIXME: yes, definitely need the gf!
+(defmethod specializer-accepts-generalizer-p (specializer (thing symbol))
+  (specializer-accepts-generalizer-p specializer (find-class 'cons)))
+
+;;; this one might not need the GF
+(defmethod specializer-accepts-p ((specializer cons-specializer) obj)
+  (and (consp obj)
+       (eql (car obj) (%car specializer))))
+;;; but this one does: it doesn't look like it here, but at issue is
+;;; who is responsible for the SPECIALIZER< method for two distinct
+;;; user-defined specializers.
+(defmethod specializer< ((s1 cons-specializer) (s2 cons-specializer) generalizer)
+  (declare (ignore generalizer))
+  (if (eql (%car s1) (%car s2))
+      '=
+      nil))
+(defmethod specializer< ((s1 cons-specializer) (s2 class) generalizer)
+  (declare (ignore generalizer))
+  '<)
+(defmethod specializer< ((s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
+  (declare (ignore generalizer))
+  '>)
+(defmethod specializer< ((s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
+  (ecase (specializer< s2 s1 generalizer)
+    ((<) '>)
+    ((>) '<)))
+
+(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 ,@(cddr form))))))
diff --git a/specializable.lisp b/specializable.lisp
index b1ce713..e7e365c 100644
--- a/specializable.lisp
+++ b/specializable.lisp
@@ -301,66 +301,3 @@
 		     args
 		     next)))
         primary-emf)))
-
-;;;; 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)))
-
-(defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
-  (typecase arg
-    ((cons symbol) (car arg))
-    (t (call-next-method))))
-;;; FIXME: it looks like these protocol functions should have the GF
-;;; as an argument, since generalizer-of-using-class does
-(defmethod specializer-accepts-generalizer-p ((specializer cons-specializer) thing)
-  (if (eql (%car specializer) thing)
-      (values t t)
-      (values nil t)))
-;;; FIXME: yes, definitely need the gf!  
-(defmethod specializer-accepts-generalizer-p (specializer (thing symbol))
-  (specializer-accepts-generalizer-p specializer (find-class 'cons)))
-
-(defmethod specializer-accepts-p ((specializer cons-specializer) obj)
-  (and (consp obj)
-       (eql (car obj) (%car specializer))))
-(defmethod specializer< ((s1 cons-specializer) (s2 cons-specializer) generalizer)
-  (declare (ignore generalizer))
-  (if (eql (%car s1) (%car s2))
-      '=
-      nil))
-(defmethod specializer< ((s1 cons-specializer) (s2 class) generalizer)
-  (declare (ignore generalizer))
-  '<)
-(defmethod specializer< ((s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
-  (declare (ignore generalizer))
-  '>)
-(defmethod specializer< ((s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
-  (ecase (specializer< s2 s1 generalizer)
-    ((<) '>)
-    ((>) '<)))
-
-(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 ,@(cddr form))))
-- 
2.39.5