mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
65 lines
2.1 KiB
Common Lisp
65 lines
2.1 KiB
Common Lisp
;;;; CHANGE-CLASS, obsolete instances, and methods on SLOT-VALUE-USING-CLASS
|
|
|
|
;;;; 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.
|
|
|
|
(defclass metaclass (sb-mop:standard-class) ())
|
|
|
|
(defmethod sb-mop:validate-superclass ((class metaclass) (superclass t))
|
|
NIL)
|
|
|
|
(defmethod sb-mop:validate-superclass ((class standard-class) (superclass metaclass))
|
|
T)
|
|
|
|
(defmethod sb-mop:validate-superclass ((class metaclass) (superclass standard-class))
|
|
T)
|
|
|
|
(defmethod sb-mop:validate-superclass ((class metaclass) (superclass metaclass))
|
|
T)
|
|
|
|
(defmethod sb-mop:direct-slot-definition-class ((class metaclass) &rest initargs)
|
|
(declare (ignore initargs))
|
|
(find-class 'sb-mop:standard-direct-slot-definition))
|
|
|
|
(defmethod sb-mop:effective-slot-definition-class ((class metaclass) &rest initargs)
|
|
(declare (ignore initargs))
|
|
(find-class 'sb-mop:standard-effective-slot-definition))
|
|
|
|
(defmethod sb-mop:slot-value-using-class ((class metaclass) object slot)
|
|
(if (eq 'test (sb-mop:slot-definition-name slot))
|
|
(* 2 (call-next-method))
|
|
(call-next-method)))
|
|
|
|
(defmethod (setf sb-mop:slot-value-using-class) (value (class metaclass) object slot)
|
|
(if (eq 'test (sb-mop:slot-definition-name slot))
|
|
(call-next-method (/ value 2) class object slot)
|
|
(call-next-method)))
|
|
|
|
(defclass stdclass ()
|
|
((test :initform 2))
|
|
(:metaclass metaclass))
|
|
|
|
(let ((a (make-instance 'stdclass)))
|
|
(assert (= 2 (slot-value a 'test)))
|
|
(change-class a 'stdclass)
|
|
(assert (= 2 (slot-value a 'test))))
|
|
|
|
;;; check obsolete instance handling
|
|
(defvar *a* (make-instance 'stdclass))
|
|
|
|
(defclass stdclass ()
|
|
((test :initform 2)
|
|
(newtest :initform 4))
|
|
(:metaclass metaclass))
|
|
|
|
(assert (= 2 (slot-value *a* 'test)))
|
|
(assert (= 4 (slot-value *a* 'newtest)))
|