tests/mop-24.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 ;;; Some slot-valuish things in combination with user-defined methods
  15
  16 (defclass user-method (standard-method) (myslot))
  17
  18 (defmacro def-user-method (name &rest rest)
  19   (let* ((lambdalist-position (position-if #'listp rest))
  20          (qualifiers (subseq rest 0 lambdalist-position))
  21          (lambdalist (elt rest lambdalist-position))
  22          (body (subseq rest (+ lambdalist-position 1)))
  23          (required-part
  24           (subseq lambdalist 0
  25                   (or (position-if #'(lambda (x)
  26                                        (member x lambda-list-keywords))
  27                                    lambdalist)
  28                       (length lambdalist))))
  29          (specializers
  30           (mapcar #'find-class
  31                   (mapcar #'(lambda (x) (if (consp x) (second x) 't))
  32                           required-part)))
  33          (unspecialized-required-part
  34           (mapcar #'(lambda (x) (if (consp x) (first x) x)) required-part))
  35          (unspecialized-lambdalist
  36           (append unspecialized-required-part
  37                   (subseq required-part (length required-part)))))
  38     `(progn
  39       (add-method #',name
  40        (make-instance 'user-method
  41         :qualifiers ',qualifiers
  42         :lambda-list ',unspecialized-lambdalist
  43         :specializers ',specializers
  44         :function
  45
  46         #'(lambda (arguments next-methods-list)
  47             (flet ((next-method-p () next-methods-list)
  48                    (call-next-method (&rest new-arguments)
  49                      (unless new-arguments (setq new-arguments arguments))
  50                      (if (null next-methods-list)
  51                          (error "no next method for arguments ~:s" arguments)
  52                          (funcall (sb-mop:method-function (first next-methods-list))
  53                                   new-arguments (rest next-methods-list)))))
  54               (apply #'(lambda ,unspecialized-lambdalist ,@body) arguments)))))
  55       ',name)))
  56
  57 (defclass super ()
  58   ((a :initarg :a :initform 3)))
  59 (defclass sub (super)
  60   ((b :initarg :b :initform 4)))
  61 (defclass subsub (sub)
  62   ((b :initarg :b :initform 5)
  63    (a :initarg :a :initform 6)))
  64
  65 ;;; reworking of MOP-20 tests, but with slot-valuish things.
  66 (progn
  67   (defgeneric test-um03 (x))
  68   (defmethod test-um03 ((x subsub))
  69     (list* 'subsub (slot-value x 'a) (slot-value x 'b)
  70            (not (null (next-method-p))) (call-next-method)))
  71   (def-user-method test-um03 ((x sub))
  72     (list* 'sub (slot-value x 'a) (slot-value x 'b)
  73            (not (null (next-method-p))) (call-next-method)))
  74   (defmethod test-um03 ((x super))
  75     (list 'super (slot-value x 'a) (not (null (next-method-p))))))
  76
  77 (with-test (:name (:mop-24 1))
  78   (assert (equal (test-um03 (make-instance 'super)) '(super 3 nil)))
  79   (assert (equal (test-um03 (make-instance 'sub)) '(sub 3 4 t super 3 nil)))
  80   (assert (equal (test-um03 (make-instance 'subsub))
  81                  '(subsub 6 5 t sub 6 5 t super 6 nil))))
  82
  83 (progn
  84   (defgeneric test-um10 (x))
  85   (defmethod test-um10 ((x subsub))
  86     (list* 'subsub (slot-value x 'a) (slot-value x 'b)
  87            (not (null (next-method-p))) (call-next-method)))
  88   (defmethod test-um10 ((x sub))
  89     (list* 'sub (slot-value x 'a) (slot-value x 'b)
  90            (not (null (next-method-p))) (call-next-method)))
  91   (defmethod test-um10 ((x super))
  92     (list 'super (slot-value x 'a) (not (null (next-method-p)))))
  93   (defmethod test-um10 :after ((x super)))
  94   (def-user-method test-um10 :around ((x subsub))
  95     (list* 'around-subsub (slot-value x 'a) (slot-value x 'b)
  96            (not (null (next-method-p))) (call-next-method)))
  97   (defmethod test-um10 :around ((x sub))
  98     (list* 'around-sub (slot-value x 'a) (slot-value x 'b)
  99            (not (null (next-method-p))) (call-next-method)))
 100   (defmethod test-um10 :around ((x super))
 101     (list* 'around-super (slot-value x 'a)
 102            (not (null (next-method-p))) (call-next-method))))
 103
 104 (with-test (:name (:mop-24 2))
 105   (assert (equal (test-um10 (make-instance 'super))
 106                  '(around-super 3 t super 3 nil)))
 107   (assert (equal (test-um10 (make-instance 'sub))
 108                  '(around-sub 3 4 t around-super 3 t sub 3 4 t super 3 nil)))
 109   (assert (equal (test-um10 (make-instance 'subsub))
 110                  '(around-subsub 6 5 t around-sub 6 5 t around-super 6 t
 111                    subsub 6 5 t sub 6 5 t super 6 nil))))
 112
 113 (progn
 114   (defgeneric test-um12 (x))
 115   (defmethod test-um12 ((x subsub))
 116     (list* 'subsub (slot-value x 'a) (slot-value x 'b)
 117            (not (null (next-method-p))) (call-next-method)))
 118   (defmethod test-um12 ((x sub))
 119     (list* 'sub (slot-value x 'a) (slot-value x 'b)
 120            (not (null (next-method-p))) (call-next-method)))
 121   (defmethod test-um12 ((x super))
 122     (list 'super (slot-value x 'a) (not (null (next-method-p)))))
 123   (defmethod test-um12 :after ((x super)))
 124   (defmethod test-um12 :around ((x subsub))
 125     (list* 'around-subsub (slot-value x 'a) (slot-value x 'b)
 126            (not (null (next-method-p))) (call-next-method)))
 127   (defmethod test-um12 :around ((x sub))
 128     (list* 'around-sub (slot-value x 'a) (slot-value x 'b)
 129            (not (null (next-method-p))) (call-next-method)))
 130   (def-user-method test-um12 :around ((x super))
 131     (list* 'around-super (slot-value x 'a)
 132            (not (null (next-method-p))) (call-next-method))))
 133
 134 (with-test (:name (:mop-24 3))
 135   (assert (equal (test-um12 (make-instance 'super))
 136                  '(around-super 3 t super 3 nil)))
 137   (assert (equal (test-um12 (make-instance 'sub))
 138                  '(around-sub 3 4 t around-super 3 t sub 3 4 t super 3 nil)))
 139   (assert (equal (test-um12 (make-instance 'subsub))
 140                  '(around-subsub 6 5 t around-sub 6 5 t around-super 6 t
 141                    subsub 6 5 t sub 6 5 t super 6 nil))))