common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Allow just slot-makunbound-using-class to be redefined.

Browse source 
Make it look like slot-boundp-using-class is non standard if there are
slot-makunbound-using-class methods.

Fixes lp#1956621
This commit is contained in:
Stas Boukarev 2022-11-02 23:33:36 +03:00
parent 4dd9bcf4a6
commit a22f1f3022
3 changed files with 30 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
src/pcl/methods.lisp
View file

@ -898,7 +898,12 @@
(types1 `((eql ,class) (class-eq ,class) (eql ,slotd)))
(types (if (eq type 'writer) `(t ,@types1) types1))
(methods (compute-applicable-methods-using-types gf types))
(std-p (null (cdr methods))))
(std-p (and (null (cdr methods))
(if (eq type 'boundp)
(null (cdr (compute-applicable-methods-using-types
(load-time-value #'slot-makunbound-using-class t)
types)))
t))))
(values
(if std-p
(get-optimized-std-accessor-method-function class slotd type)
@ -1587,6 +1592,9 @@
((eq gf (load-time-value #'slot-boundp-using-class t))
(update-slot-value-gf-info gf 'boundp)
#'slot-boundp-using-class-dfun)
((and (eq gf (load-time-value #'slot-makunbound-using-class t))
(update-slot-value-gf-info (load-time-value #'slot-boundp-using-class t) 'boundp)
nil))
;; KLUDGE: PRINT-OBJECT is not a special-case in the sense
;; of having a desperately special discriminating function.
;; However, it is important that the machinery for printing

5
src/pcl/std-class.lisp
View file

@ -87,7 +87,10 @@
(let* ((types1 `((eql ,class) (class-eq ,class) (eql ,slotd)))
(types (if (eq type 'writer) `(t ,@types1) types1))
(methods (compute-applicable-methods-using-types gf types)))
(null (cdr methods))))
(and (null (cdr methods))
(or (neq type 'boundp)
(null (cdr (compute-applicable-methods-using-types
(gdefinition 'slot-makunbound-using-class) types)))))))
(setf (slot-accessor-function slotd type)
(lambda (&rest args)
(declare (dynamic-extent args))

17
tests/mop-2.impure-cload.lisp
View file

@ -258,3 +258,20 @@
(slot (find 'slot2 slots :key #'sb-mop:slot-definition-name)))
(assert (eq :dynamic (sb-mop:slot-definition-allocation slot)))
(assert (eq 'ok! (slot-value *three* 'slot2)))))
(defclass makunbound-test-class (standard-class) ())
(defmethod sb-mop:validate-superclass ((class makunbound-test-class) (superclass standard-class))
t)
(defmethod sb-mop:slot-makunbound-using-class ((class makunbound-test-class) object slotd)
(throw 'slot-makunbound-using-class t))
(defclass test-class ()
((slot :initarg :slot))
(:metaclass makunbound-test-class))
(with-test (:name :slot-makunbound-using-class)
(assert (catch 'slot-makunbound-using-class
(slot-makunbound (make-instance 'test-class) 'slot)
nil)))