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

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))))