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 sb-pcl:specializer-type-specifier
  48     ((proto-generic-function pattern-gf/1)
  49      (proto-method t)
  50      (specializer pattern-specializer))
  51   (labels ((to-type (pattern)
  52              (cond
  53                ((null pattern) 't)
  54                ((atom pattern) `(eql ,pattern))
  55                (t `(cons ,(to-type (car pattern))
  56                          ,(to-type (cdr pattern)))))))
  57     (to-type (pattern specializer))))
  58
  59 (defun matchesp (arg pattern)
  60   (cond
  61     ((null pattern) t)
  62     ((atom pattern) (eql arg pattern))
  63     (t (and (matchesp (car arg) (car pattern))
  64             (matchesp (cdr arg) (cdr pattern))))))
  65
  66 (defun method-interpreting-function (methods gf)
  67   (lambda (arg)
  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))))))
  71
  72 (defmethod compute-discriminating-function ((generic-function pattern-gf/1))
  73   (lambda (arg)
  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))))
  78
  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))))
  87 \f
  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)))
 101
 102 (assert (eql (simplify '(* 0 3)) 0))
 103 (assert (eql (simplify '(* (+ x y) 0)) 0))
 104 (assert (equal (simplify '(+ x y)) '(+ x y)))