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