Merge branch 'master' of git://repo.or.cz/sbcl
[sbcl/attila.git] / tests / mop-25.impure.lisp
blob9836e47c4068d87f883b7936aa4951804528a6f0
1 ;;;; miscellaneous side-effectful tests of the MOP
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.
14 ;;; be sure that the :FUNCTION initarg to initialize methods overrides
15 ;;; any system-provided function.
17 (defpackage "MOP-25"
18 (:use "CL" "SB-MOP"))
20 (in-package "MOP-25")
22 (defclass typechecking-reader-method (standard-reader-method)
23 ())
25 (defmethod initialize-instance
26 ((method typechecking-reader-method) &rest initargs &key slot-definition)
27 (let ((name (slot-definition-name slot-definition))
28 (type (slot-definition-type slot-definition)))
29 (apply #'call-next-method method
30 :function #'(lambda (args next-methods)
31 (declare (ignore next-methods))
32 (apply #'(lambda (instance)
33 (let ((value (slot-value instance name)))
34 (unless (typep value type)
35 (error "Slot ~S of ~S is not of type ~S: ~S"
36 name instance type value))
37 value))
38 args))
39 initargs)))
40 (defclass typechecking-reader-class (standard-class)
41 ())
43 (defmethod validate-superclass ((c1 typechecking-reader-class) (c2 standard-class))
46 (defmethod reader-method-class
47 ((class typechecking-reader-class) direct-slot &rest args)
48 (find-class 'typechecking-reader-method))
50 (defclass testclass25 ()
51 ((pair :type (cons symbol (cons symbol null)) :initarg :pair :accessor testclass25-pair))
52 (:metaclass typechecking-reader-class))
54 (assert (equal '(t t t nil t)
55 (macrolet ((succeeds (form)
56 `(not (nth-value 1 (ignore-errors ,form)))))
57 (let ((p (list 'abc 'def))
58 (x (make-instance 'testclass25)))
59 (list (succeeds (make-instance 'testclass25 :pair '(seventeen 17)))
60 (succeeds (setf (testclass25-pair x) p))
61 (succeeds (setf (second p) 456))
62 (succeeds (testclass25-pair x))
63 (succeeds (slot-value x 'pair)))))))