Clean up listify-rest-args VOP on x86-64.
[sbcl.git] / tests / mop-27.impure.lisp
1 ;;;; miscellaneous side-effectful tests of the MOP
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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.
13
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
18 ;;; matching"
19
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).
26
27 (defpackage "MOP-27"
28   (:use "CL" "SB-MOP"))
29
30 (in-package "MOP-27")
31
32 (defclass pattern-specializer (specializer)
33   ((pattern :initarg pattern :reader pattern)
34    (direct-methods :initform nil :reader specializer-direct-methods)))
35
36 (defvar *pattern-specializer-table* (make-hash-table :test 'equal))
37
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))))
42
43 ;;; only one arg for now
44 (defclass pattern-gf/1 (standard-generic-function) ()
45   (:metaclass funcallable-standard-class))
46
47 (defmethod compute-discriminating-function ((generic-function pattern-gf/1))
48   (lambda (arg)
49     (let* ((methods (generic-function-methods generic-function))
50            (function (method-interpreting-function methods generic-function)))
51       (set-funcallable-instance-function generic-function function)
52       (funcall function arg))))
53
54 (defun method-interpreting-function (methods gf)
55   (lambda (arg)
56     (dolist (method methods (no-applicable-method gf (list arg)))
57       (when (matchesp arg (pattern (car (method-specializers method))))
58         (return (funcall (method-function method) (list arg) nil))))))
59
60 (defun matchesp (arg pattern)
61   (cond
62     ((null pattern) t)
63     ((atom pattern) (eql arg pattern))
64     (t (and (matchesp (car arg) (car pattern))
65             (matchesp (cdr arg) (cdr pattern))))))
66
67
68 ;;; protocol functions.  SPECIALIZER-DIRECT-METHODS is implemented by
69 ;;; a reader on the specializer.  FIXME: implement
70 ;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS.
71 (defmethod add-direct-method ((specializer pattern-specializer) method)
72   (pushnew method (slot-value specializer 'direct-methods)))
73 (defmethod remove-direct-method ((specializer pattern-specializer) method)
74   (setf (slot-value specializer 'direct-methods)
75         (remove method (slot-value specializer 'direct-methods))))
76 \f
77 (defgeneric simplify (x)
78   (:generic-function-class pattern-gf/1))
79 ;;; KLUDGE: order of definition matters, as we simply traverse
80 ;;; generic-function-methods until a pattern matches our argument.
81 ;;; Additionally, we're not doing anything interesting with regard to
82 ;;; destructuring the pattern for use in the method body; a real
83 ;;; implementation would make it more convenient.
84 (let ((specializer (ensure-pattern-specializer 'nil)))
85   (eval `(defmethod simplify ((x ,specializer)) x)))
86 (let ((specializer (ensure-pattern-specializer '(* nil 0))))
87   (eval `(defmethod simplify ((x ,specializer)) 0)))
88 (let ((specializer (ensure-pattern-specializer '(* 0 nil))))
89   (eval `(defmethod simplify ((x ,specializer)) 0)))
90
91 (assert (eql (simplify '(* 0 3)) 0))
92 (assert (eql (simplify '(* (+ x y) 0)) 0))
93 (assert (equal (simplify '(+ x y)) '(+ x y)))