Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv15358/tests
Added Files:
mop-24.impure.lisp mop-25.impure.lisp
Log Message:
0.9.15.17:
Implement the :FUNCTION initarg for method initialization
... half of the battle here was altering the propagation of
information about methods around the system. Prior
to this checkin, information was kept in a (non-weak)
hash table holding plists for method functions and
method fast functions. Instead, we associate the
plist with the method itself.
... implement method-qualifiers as a proper slot reader, rather
than through the plist;
... method-function-get-DIE-DIE-DIE
... constant-method-call and constant-fast-method-call
structures for the special case of constant-value
(e.g. predicate) generic functions
... remove :METHOD-SPEC initarg, since it's useless
... rely more on interning instead of METHOD-FUNCTION-PV-TABLE
... remove dead code (e.g. METHOD-FUNCTION-CLOSURE-GENERATOR,
MAKE-INTERNAL-READER-METHOD-FUNCTION)
... define a %METHOD-FUNCTION funcallable structure, to bind
function and fast-function closely together.
... remove the :FAST-FUNCTION initarg. Now, if the system wants
a fast-function, it creates a %method-function structure
with the fast-function in the fast-function slot (and
an ordinary method-function as the
funcallable-instance-function)
... some test cases. (This fixes bug #361 among others, and we
have no current failures against the Closer
mop-feature-tests)
--- NEW FILE: mop-24.impure.lisp ---
;;;; 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))))
--- NEW FILE: mop-25.impure.lisp ---
;;;; 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.
;;; be sure that the :FUNCTION initarg to initialize methods overrides
;;; any system-provided function.
(defpackage "MOP-25"
(:use "CL" "SB-MOP"))
(in-package "MOP-25")
(defclass typechecking-reader-method (standard-reader-method)
())
(defmethod initialize-instance
((method typechecking-reader-method) &rest initargs &key slot-definition)
(let ((name (slot-definition-name slot-definition))
(type (slot-definition-type slot-definition)))
(apply #'call-next-method method
:function #'(lambda (args next-methods)
(declare (ignore next-methods))
(apply #'(lambda (instance)
(let ((value (slot-value instance name)))
(unless (typep value type)
(error "Slot ~S of ~S is not of type ~S: ~S"
name instance type value))
value))
args))
initargs)))
(defclass typechecking-reader-class (standard-class)
())
(defmethod validate-superclass ((c1 typechecking-reader-class) (c2 standard-class))
t)
(defmethod reader-method-class
((class typechecking-reader-class) direct-slot &rest args)
(find-class 'typechecking-reader-method))
(defclass testclass25 ()
((pair :type (cons symbol (cons symbol null)) :initarg :pair :accessor testclass25-pair))
(:metaclass typechecking-reader-class))
(assert (equal '(t t t nil t)
(macrolet ((succeeds (form)
`(not (nth-value 1 (ignore-errors ,form)))))
(let ((p (list 'abc 'def))
(x (make-instance 'testclass25)))
(list (succeeds (make-instance 'testclass25 :pair '(seventeen 17)))
(succeeds (setf (testclass25-pair x) p))
(succeeds (setf (second p) 456))
(succeeds (testclass25-pair x))
(succeeds (slot-value x 'pair)))))))
|