1 ;;;; miscellaneous side-effectful tests of the MOP
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 ;;; a test of a non-standard specializer class. Some context: a
15 ;;; (mostly content-free) discussion on comp.lang.lisp around
16 ;;; 2007-05-08 about the merits of Lisp, wherein an F#/OCaml advocate
17 ;;; implies roughly "I've heard that CLOS is slower than pattern
20 ;;; This implements a generic function type which dispatches on
21 ;;; patterns in its methods. The implementation below is a simple
22 ;;; interpreter of patterns; compiling the patterns into a
23 ;;; discrimination net, or other optimized dispatch structure, would
24 ;;; be an interesting exercise for the reader. (As would fixing some
25 ;;; other marked issues).
32 (defclass pattern-specializer
(specializer)
33 ((pattern :initarg pattern
:reader pattern
)
34 (direct-methods :initform nil
:reader specializer-direct-methods
)))
36 (defvar *pattern-specializer-table
* (make-hash-table :test
'equal
))
38 (defun ensure-pattern-specializer (pattern)
39 (or (gethash pattern
*pattern-specializer-table
*)
40 (setf (gethash pattern
*pattern-specializer-table
*)
41 (make-instance 'pattern-specializer
'pattern pattern
))))
43 ;;; only one arg for now
44 (defclass pattern-gf
/1 (standard-generic-function) ()
45 (:metaclass funcallable-standard-class
))
47 (defmethod sb-pcl:specializer-type-specifier
48 ((proto-generic-function pattern-gf
/1)
50 (specializer pattern-specializer
))
51 (labels ((to-type (pattern)
54 ((atom pattern
) `(eql ,pattern
))
55 (t `(cons ,(to-type (car pattern
))
56 ,(to-type (cdr pattern
)))))))
57 (to-type (pattern specializer
))))
59 (defun matchesp (arg pattern
)
62 ((atom pattern
) (eql arg pattern
))
63 (t (and (matchesp (car arg
) (car pattern
))
64 (matchesp (cdr arg
) (cdr pattern
))))))
66 (defun method-interpreting-function (methods gf
)
68 (dolist (method methods
(no-applicable-method gf
(list arg
)))
69 (when (matchesp arg
(pattern (car (method-specializers method
))))
70 (return (funcall (method-function method
) (list arg
) nil
))))))
72 (defmethod compute-discriminating-function ((generic-function pattern-gf
/1))
74 (let* ((methods (generic-function-methods generic-function
))
75 (function (method-interpreting-function methods generic-function
)))
76 (set-funcallable-instance-function generic-function function
)
77 (funcall function arg
))))
79 ;;; protocol functions. SPECIALIZER-DIRECT-METHODS is implemented by
80 ;;; a reader on the specializer. FIXME: implement
81 ;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS.
82 (defmethod add-direct-method ((specializer pattern-specializer
) method
)
83 (pushnew method
(slot-value specializer
'direct-methods
)))
84 (defmethod remove-direct-method ((specializer pattern-specializer
) method
)
85 (setf (slot-value specializer
'direct-methods
)
86 (remove method
(slot-value specializer
'direct-methods
))))
88 (defgeneric simplify
(x)
89 (:generic-function-class pattern-gf
/1))
90 ;;; KLUDGE: order of definition matters, as we simply traverse
91 ;;; generic-function-methods until a pattern matches our argument.
92 ;;; Additionally, we're not doing anything interesting with regard to
93 ;;; destructuring the pattern for use in the method body; a real
94 ;;; implementation would make it more convenient.
95 (let ((specializer (ensure-pattern-specializer 'nil
)))
96 (eval `(defmethod simplify ((x ,specializer
)) x
)))
97 (let ((specializer (ensure-pattern-specializer '(* nil
0))))
98 (eval `(defmethod simplify ((x ,specializer
)) 0)))
99 (let ((specializer (ensure-pattern-specializer '(* 0 nil
))))
100 (eval `(defmethod simplify ((x ,specializer
)) 0)))
102 (assert (eql (simplify '(* 0 3)) 0))
103 (assert (eql (simplify '(* (+ x y
) 0)) 0))
104 (assert (equal (simplify '(+ x y
)) '(+ x y
)))