--- /dev/null
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; Some slot-valuish things in combination with user-defined methods
+
+(defpackage "MOP-24"
+ (:use "CL" "SB-MOP"))
+
+(in-package "MOP-24")
+
+(defclass user-method (standard-method) (myslot))
+
+(defmacro def-user-method (name &rest rest)
+ (let* ((lambdalist-position (position-if #'listp rest))
+ (qualifiers (subseq rest 0 lambdalist-position))
+ (lambdalist (elt rest lambdalist-position))
+ (body (subseq rest (+ lambdalist-position 1)))
+ (required-part
+ (subseq lambdalist 0
+ (or (position-if #'(lambda (x)
+ (member x lambda-list-keywords))
+ lambdalist)
+ (length lambdalist))))
+ (specializers
+ (mapcar #'find-class
+ (mapcar #'(lambda (x) (if (consp x) (second x) 't))
+ required-part)))
+ (unspecialized-required-part
+ (mapcar #'(lambda (x) (if (consp x) (first x) x)) required-part))
+ (unspecialized-lambdalist
+ (append unspecialized-required-part
+ (subseq required-part (length required-part)))))
+ `(progn
+ (add-method #',name
+ (make-instance 'user-method
+ :qualifiers ',qualifiers
+ :lambda-list ',unspecialized-lambdalist
+ :specializers ',specializers
+ :function
+
+ #'(lambda (arguments next-methods-list)
+ (flet ((next-method-p () next-methods-list)
+ (call-next-method (&rest new-arguments)
+ (unless new-arguments (setq new-arguments arguments))
+ (if (null next-methods-list)
+ (error "no next method for arguments ~:s" arguments)
+ (funcall (method-function (first next-methods-list))
+ new-arguments (rest next-methods-list)))))
+ (apply #'(lambda ,unspecialized-lambdalist ,@body) arguments)))))
+ ',name)))
+
+(defclass super ()
+ ((a :initarg :a :initform 3)))
+(defclass sub (super)
+ ((b :initarg :b :initform 4)))
+(defclass subsub (sub)
+ ((b :initarg :b :initform 5)
+ (a :initarg :a :initform 6)))
+
+;;; reworking of MOP-20 tests, but with slot-valuish things.
+(progn
+ (defgeneric test-um03 (x))
+ (defmethod test-um03 ((x subsub))
+ (list* 'subsub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (def-user-method test-um03 ((x sub))
+ (list* 'sub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um03 ((x super))
+ (list 'super (slot-value x 'a) (not (null (next-method-p)))))
+ (assert (equal (test-um03 (make-instance 'super)) '(super 3 nil)))
+ (assert (equal (test-um03 (make-instance 'sub)) '(sub 3 4 t super 3 nil)))
+ (assert (equal (test-um03 (make-instance 'subsub))
+ '(subsub 6 5 t sub 6 5 t super 6 nil))))
+
+(progn
+ (defgeneric test-um10 (x))
+ (defmethod test-um10 ((x subsub))
+ (list* 'subsub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um10 ((x sub))
+ (list* 'sub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um10 ((x super))
+ (list 'super (slot-value x 'a) (not (null (next-method-p)))))
+ (defmethod test-um10 :after ((x super)))
+ (def-user-method test-um10 :around ((x subsub))
+ (list* 'around-subsub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um10 :around ((x sub))
+ (list* 'around-sub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um10 :around ((x super))
+ (list* 'around-super (slot-value x 'a)
+ (not (null (next-method-p))) (call-next-method)))
+ (assert (equal (test-um10 (make-instance 'super))
+ '(around-super 3 t super 3 nil)))
+ (assert (equal (test-um10 (make-instance 'sub))
+ '(around-sub 3 4 t around-super 3 t sub 3 4 t super 3 nil)))
+ (assert (equal (test-um10 (make-instance 'subsub))
+ '(around-subsub 6 5 t around-sub 6 5 t around-super 6 t
+ subsub 6 5 t sub 6 5 t super 6 nil))))
+
+(progn
+ (defgeneric test-um12 (x))
+ (defmethod test-um12 ((x subsub))
+ (list* 'subsub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um12 ((x sub))
+ (list* 'sub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um12 ((x super))
+ (list 'super (slot-value x 'a) (not (null (next-method-p)))))
+ (defmethod test-um12 :after ((x super)))
+ (defmethod test-um12 :around ((x subsub))
+ (list* 'around-subsub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um12 :around ((x sub))
+ (list* 'around-sub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (def-user-method test-um12 :around ((x super))
+ (list* 'around-super (slot-value x 'a)
+ (not (null (next-method-p))) (call-next-method)))
+ (assert (equal (test-um12 (make-instance 'super))
+ '(around-super 3 t super 3 nil)))
+ (assert (equal (test-um12 (make-instance 'sub))
+ '(around-sub 3 4 t around-super 3 t sub 3 4 t super 3 nil)))
+ (assert (equal (test-um12 (make-instance 'subsub))
+ '(around-subsub 6 5 t around-sub 6 5 t around-super 6 t
+ subsub 6 5 t sub 6 5 t super 6 nil))))
projects / sbcl.git / blobdiff