[clg] / gffi / virtual-slots.lisp

;; Common Lisp bindings for GTK+ v2.x
;; Copyright 2000-2006 Espen S. Johnsen <espen@users.sf.net>
;;
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

;; $Id: virtual-slots.lisp,v 1.4 2006-09-05 13:16:18 espen Exp $

(in-package "GFFI")

;;;; Superclass for all metaclasses implementing some sort of virtual slots

(defclass virtual-slots-class (standard-class) 
  ())

(defclass direct-virtual-slot-definition (standard-direct-slot-definition)
  ((setter :reader slot-definition-setter :initarg :setter)
   (getter :reader slot-definition-getter :initarg :getter)
   (unbound :reader slot-definition-unbound :initarg :unbound)
   (boundp :reader slot-definition-boundp :initarg :boundp)
   (makunbound :reader slot-definition-makunbound :initarg :makunbound)
   #+clisp(type :initarg :type :reader slot-definition-type)))
  
(defclass effective-virtual-slot-definition (standard-effective-slot-definition)
  ((setter :reader slot-definition-setter :initarg :setter)
   (getter :reader slot-definition-getter :initarg :getter)
   (unbound :reader slot-definition-unbound :initarg :unbound)
   (boundp :reader slot-definition-boundp :initarg :boundp)
   (makunbound :reader slot-definition-makunbound :initarg :makunbound)
   #+clisp(reader-function)
   #+clisp(writer-function)
   #+clisp(boundp-function)
   makunbound-function
   #+clisp(type :initarg :type :reader slot-definition-type)))

(defclass direct-special-slot-definition (standard-direct-slot-definition)
  ((special :initarg :special :accessor slot-definition-special)))

(defclass effective-special-slot-definition (standard-effective-slot-definition)
  ((special :initarg :special :accessor slot-definition-special)))

(defclass virtual-slots-object (standard-object)
  ())

(defgeneric slot-readable-p (slotd))
(defgeneric slot-writable-p (slotd))
(defgeneric compute-slot-reader-function (slotd &optional signal-unbound-p))
(defgeneric compute-slot-boundp-function (slotd))
(defgeneric compute-slot-writer-function (slotd))
(defgeneric compute-slot-makunbound-function (slotd))

(defmethod slot-readable-p ((slotd standard-effective-slot-definition))
  (declare (ignore slotd))
  t)

(defmethod slot-writable-p ((slotd standard-effective-slot-definition))
  (declare (ignore slotd))
  t)


#+clisp
(defmethod slot-definition-type ((slotd t))
  (clos:slot-definition-type slotd))


(defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs)
  (cond
   ((eq (getf initargs :allocation) :virtual)
    (find-class 'direct-virtual-slot-definition))
   ((getf initargs :special)
    (find-class 'direct-special-slot-definition))
   (t (call-next-method))))

(defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs)
  (cond
   ((eq (getf initargs :allocation) :virtual)
    (find-class 'effective-virtual-slot-definition))
   ((getf initargs :special)
    (find-class 'effective-special-slot-definition))
   (t (call-next-method))))


(defmethod slot-readable-p ((slotd effective-virtual-slot-definition))
  (slot-boundp slotd 'getter))

(define-condition unreadable-slot (cell-error)
  ((instance :reader unreadable-slot-instance :initarg :instance))
  (:report (lambda (condition stream)
	     (format stream "~@<The slot ~S in the object ~S is not readable.~@:>"
	      (cell-error-name condition)
	      (unreadable-slot-instance condition)))))

(defmethod compute-slot-reader-function :around ((slotd effective-virtual-slot-definition) &optional (signal-unbound-p t))
  (if (not (slot-readable-p slotd))
      #'(lambda (object)
	  (error 'unreadable-slot :name (slot-definition-name slotd) :instance object))
    (let ((reader-function (call-next-method)))
      (cond
       ;; Don't create wrapper to signal unbound value
       ((not signal-unbound-p) reader-function)
       
       ;; An explicit boundp function has been supplied
       ((slot-boundp slotd 'boundp) 
	(let ((unbound-value (slot-value slotd 'boundp)))
	  #'(lambda (object)
	      (let ((value (funcall reader-function object)))
		(if (eq value unbound-value)
		    (slot-unbound (class-of object) object (slot-definition-name slotd))
		  value)))))
       
       ;; A type unbound value exists
       ((let ((unbound-method (find-applicable-type-method 'unbound-value 
			       (slot-definition-type slotd) nil)))
	  (when unbound-method
	    (let ((unbound-value (funcall unbound-method (slot-definition-type slotd))))
	      #'(lambda (object)
		  (let ((value (funcall reader-function object)))
		    (if (eq value unbound-value)
			(slot-unbound (class-of object) object (slot-definition-name slotd))
		      value)))))))
       
       ((let ((boundp-function (compute-slot-boundp-function slotd)))
	  #'(lambda (object)
	      (if (funcall boundp-function object)
		  (funcall reader-function object)
		(slot-unbound (class-of object) object (slot-definition-name slotd))))))))))

(defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition) &optional signal-unbound-p)
  (declare (ignore signal-unbound-p))
  (slot-value slotd 'getter))

(defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definition))
  (cond
   ;; Non readable slots are not bound per definition
   ((not (slot-readable-p slotd))
    #'(lambda (object) (declare (ignore object)) nil))

   ;; An explicit boundp function has been supplied
   ((slot-boundp slotd 'boundp) (slot-value slotd 'boundp))
   
   ;; An unbound value has been supplied
   ((slot-boundp slotd 'unbound)
    (let ((reader-function (compute-slot-reader-function slotd nil))
	  (unbound-value (slot-value slotd 'unbound)))
      #'(lambda (object)
	  (not (eql (funcall reader-function object) unbound-value)))))
   
   ;; A type unbound value exists
   ((let ((unbound-method (find-applicable-type-method 'unbound-value 
			   (slot-definition-type slotd) nil)))
      (when unbound-method
	(let ((reader-function (compute-slot-reader-function slotd nil))
	      (unbound-value (funcall unbound-method (slot-definition-type slotd))))
	  #'(lambda (object)
	      (not (eql (funcall reader-function object) unbound-value)))))))
   
   ;; Slot has no unbound state
   (#'(lambda (object) (declare (ignore object)) t))))

(defmethod slot-writable-p ((slotd effective-virtual-slot-definition))
  (slot-boundp slotd 'setter))

(define-condition unwritable-slot (cell-error)
  ((instance :reader unwritable-slot-instance :initarg :instance))
  (:report (lambda (condition stream)
	     (format stream "~@<The slot ~S in the object ~S is not writable.~@:>"
	      (cell-error-name condition)
	      (unwritable-slot-instance condition)))))

(defmethod compute-slot-writer-function :around ((slotd effective-virtual-slot-definition))
  (if (not (slot-writable-p slotd))
      #'(lambda (value object)
	  (declare (ignore value))
	  (error 'unwritable-slot :name (slot-definition-name slotd) :instance object))
    (call-next-method)))

(defmethod compute-slot-writer-function ((slotd effective-virtual-slot-definition))
  (slot-value slotd 'setter))

(define-condition slot-can-not-be-unbound (cell-error)
  ((instance :reader slot-can-not-be-unbound-instance :initarg :instance))
  (:report (lambda (condition stream)
	     (format stream "~@<The slot ~S in the object ~S can not be made unbound.~@:>"
	      (cell-error-name condition)
	      (slot-can-not-be-unbound-instance condition)))))

(defmethod compute-slot-makunbound-function ((slotd effective-virtual-slot-definition))
  (cond
   ((not (slot-writable-p slotd))
    #'(lambda (object)
	(error 'unwritable-slot :name (slot-definition-name slotd) :instance object)))
   ((slot-boundp slotd 'makunbound) (slot-value slotd 'makunbound))
   ((slot-boundp slotd 'unbound)
    #'(lambda (object)
	(funcall (slot-value slotd 'writer-function) (slot-value slotd 'unbound) object)))
   (t
    #'(lambda (object)
	(error 'slot-can-not-be-unbound :name (slot-definition-name slotd) :instance object)))))


#-clisp
(defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
  #?-(sbcl>= 0 9 15) ; Delayed to avoid recursive call of finalize-inheritanze
  (setf 
   (slot-value slotd 'reader-function) (compute-slot-reader-function slotd)
   (slot-value slotd 'boundp-function) (compute-slot-boundp-function slotd)
   (slot-value slotd 'writer-function) (compute-slot-writer-function slotd)
   (slot-value slotd 'makunbound-function) (compute-slot-makunbound-function slotd))

  #?-(sbcl>= 0 9 8)(initialize-internal-slot-gfs (slot-definition-name slotd)))


#-clisp
(defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf)
  nil)


(defun slot-bound-in-some-p (instances slot)
  (find-if
   #'(lambda (ob)
       (and (slot-exists-p ob slot) (slot-boundp ob slot)))
   instances))

(defun most-specific-slot-value (instances slot &optional default)
  (let ((object (slot-bound-in-some-p instances slot)))
    (if object
	(slot-value object slot)
      default)))

(defun compute-most-specific-initargs (slotds slots)
  (loop
   for slot in slots
   as (slot-name initarg) = (if (atom slot)
				(list slot (intern (string slot) "KEYWORD"))
			      slot)
   when (slot-bound-in-some-p slotds slot-name)
   nconc (list initarg (most-specific-slot-value slotds slot-name))))

(defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
  (typecase (first direct-slotds)
    (direct-virtual-slot-definition
     (nconc
      (compute-most-specific-initargs direct-slotds
       '(getter setter unbound boundp makunbound
	 #?(or (sbcl>= 0 9 8) (featurep :clisp))
	 (#?-(sbcl>= 0 9 10)type #?(sbcl>= 0 9 10)sb-pcl::%type :type)))
      (call-next-method)))
    (direct-special-slot-definition
     (append '(:special t) (call-next-method)))
    (t (call-next-method))))

#?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
(defmethod slot-value-using-class
    ((class virtual-slots-class) (object virtual-slots-object)
     (slotd effective-virtual-slot-definition))
    (funcall (slot-value slotd 'reader-function) object))

#?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
(defmethod slot-boundp-using-class
    ((class virtual-slots-class) (object virtual-slots-object)
     (slotd effective-virtual-slot-definition))
    (funcall (slot-value slotd 'boundp-function) object))

#?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
(defmethod (setf slot-value-using-class) 
    (value (class virtual-slots-class) (object virtual-slots-object)
     (slotd effective-virtual-slot-definition))
  (funcall (slot-value slotd 'writer-function) value object))

(defmethod slot-makunbound-using-class
    ((class virtual-slots-class) (object virtual-slots-object)
     (slotd effective-virtual-slot-definition))
  (funcall (slot-value slotd 'makunbound-function) object))


;; In CLISP and SBCL (0.9.15 or newler) a class may not have been
;; finalized when update-slots are called. So to avoid the possibility
;; of finalize-instance being called recursivly we have to delay the
;; initialization of slot functions until after an instance has been
;; created.
#?(or (sbcl>= 0 9 15) (featurep :clisp))
(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'reader-function)))
  (setf (slot-value slotd name) (compute-slot-reader-function slotd)))

#?(or (sbcl>= 0 9 15) (featurep :clisp))
(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'boundp-function)))
  (setf (slot-value slotd name) (compute-slot-boundp-function slotd)))

#?(or (sbcl>= 0 9 15) (featurep :clisp))
(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'writer-function)))
  (setf (slot-value slotd name) (compute-slot-writer-function slotd)))

#?(or (sbcl>= 0 9 15) (featurep :clisp))
(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'makunbound-function)))
  (setf (slot-value slotd name) (compute-slot-makunbound-function slotd)))


(defmethod validate-superclass
    ((class virtual-slots-class) (super standard-class))
  t)

(defmethod slot-definition-special ((slotd standard-direct-slot-definition))
  (declare (ignore slotd))
  nil)

(defmethod slot-definition-special ((slotd standard-effective-slot-definition))
  (declare (ignore slotd))
  nil)


;;; To determine if a slot should be initialized with the initform,
;;; CLISP checks whether it is unbound or not. This doesn't work with
;;; virtual slots that does not have an unbound state, so we have to
;;; implement initform initialization in a way similar to how it is
;;; done in PCL.
#+clisp
(defmethod shared-initialize ((object virtual-slots-object) names &rest initargs)
  (let* ((class (class-of object))
	 (slotds (class-slots class))
	 (keywords (loop
		    for args on initargs by #'cddr
		    collect (first args)))
	 (names
	  (loop
	   for slotd in slotds
	   as name = (slot-definition-name slotd)
	   as initargs = (slot-definition-initargs slotd)
	   as init-p = (and
			(or (eq names t) (find name names))
			(slot-definition-initfunction slotd)
			(not (intersection initargs keywords)))
	   as virtual-p = (typep slotd 'effective-virtual-slot-definition)
	   when (and init-p virtual-p)
	   do (setf 
	       (slot-value-using-class class object slotd)
	       (funcall (slot-definition-initfunction slotd)))
	   when (and init-p (not virtual-p))
	   collect name)))

      (apply #'call-next-method object names initargs)))
Commit	Line	Data
4e968638	1	;; Common Lisp bindings for GTK+ v2.x
	2	;; Copyright 2000-2006 Espen S. Johnsen <espen@users.sf.net>
	3	;;
	4	;; Permission is hereby granted, free of charge, to any person obtaining
	5	;; a copy of this software and associated documentation files (the
	6	;; "Software"), to deal in the Software without restriction, including
	7	;; without limitation the rights to use, copy, modify, merge, publish,
	8	;; distribute, sublicense, and/or sell copies of the Software, and to
	9	;; permit persons to whom the Software is furnished to do so, subject to
	10	;; the following conditions:
	11	;;
	12	;; The above copyright notice and this permission notice shall be
	13	;; included in all copies or substantial portions of the Software.
	14	;;
	15	;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
	16	;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
	17	;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
	18	;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
	19	;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
	20	;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
	21	;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
	22
aed39f73	23	;; $Id: virtual-slots.lisp,v 1.4 2006-09-05 13:16:18 espen Exp $
4e968638	24
	25	(in-package "GFFI")
	26
	27	;;;; Superclass for all metaclasses implementing some sort of virtual slots
	28
584285fb	29	(defclass virtual-slots-class (standard-class)
	30	())
	31
	32	(defclass direct-virtual-slot-definition (standard-direct-slot-definition)
	33	((setter :reader slot-definition-setter :initarg :setter)
	34	(getter :reader slot-definition-getter :initarg :getter)
	35	(unbound :reader slot-definition-unbound :initarg :unbound)
	36	(boundp :reader slot-definition-boundp :initarg :boundp)
	37	(makunbound :reader slot-definition-makunbound :initarg :makunbound)
	38	#+clisp(type :initarg :type :reader slot-definition-type)))
4e968638	39
584285fb	40	(defclass effective-virtual-slot-definition (standard-effective-slot-definition)
	41	((setter :reader slot-definition-setter :initarg :setter)
	42	(getter :reader slot-definition-getter :initarg :getter)
	43	(unbound :reader slot-definition-unbound :initarg :unbound)
	44	(boundp :reader slot-definition-boundp :initarg :boundp)
	45	(makunbound :reader slot-definition-makunbound :initarg :makunbound)
	46	#+clisp(reader-function)
	47	#+clisp(writer-function)
	48	#+clisp(boundp-function)
	49	makunbound-function
	50	#+clisp(type :initarg :type :reader slot-definition-type)))
	51
	52	(defclass direct-special-slot-definition (standard-direct-slot-definition)
	53	((special :initarg :special :accessor slot-definition-special)))
	54
	55	(defclass effective-special-slot-definition (standard-effective-slot-definition)
	56	((special :initarg :special :accessor slot-definition-special)))
	57
	58	(defclass virtual-slots-object (standard-object)
	59	())
	60
2bd78f93	61	(defgeneric slot-readable-p (slotd))
2bd78f93	62	(defgeneric slot-writable-p (slotd))
584285fb	63	(defgeneric compute-slot-reader-function (slotd &optional signal-unbound-p))
4e968638	64	(defgeneric compute-slot-boundp-function (slotd))
	65	(defgeneric compute-slot-writer-function (slotd))
	66	(defgeneric compute-slot-makunbound-function (slotd))
	67
2bd78f93	68	(defmethod slot-readable-p ((slotd standard-effective-slot-definition))
	69	(declare (ignore slotd))
	70	t)
	71
	72	(defmethod slot-writable-p ((slotd standard-effective-slot-definition))
	73	(declare (ignore slotd))
	74	t)
	75
4e968638	76
	77	#+clisp
	78	(defmethod slot-definition-type ((slotd t))
	79	(clos:slot-definition-type slotd))
	80
	81
	82	(defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs)
	83	(cond
	84	((eq (getf initargs :allocation) :virtual)
	85	(find-class 'direct-virtual-slot-definition))
	86	((getf initargs :special)
	87	(find-class 'direct-special-slot-definition))
	88	(t (call-next-method))))
	89
	90	(defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs)
	91	(cond
	92	((eq (getf initargs :allocation) :virtual)
	93	(find-class 'effective-virtual-slot-definition))
	94	((getf initargs :special)
	95	(find-class 'effective-special-slot-definition))
	96	(t (call-next-method))))
	97
	98
2bd78f93	99	(defmethod slot-readable-p ((slotd effective-virtual-slot-definition))
	100	(slot-boundp slotd 'getter))
	101
4e968638	102	(define-condition unreadable-slot (cell-error)
	103	((instance :reader unreadable-slot-instance :initarg :instance))
	104	(:report (lambda (condition stream)
	105	(format stream "~@<The slot ~S in the object ~S is not readable.~@:>"
	106	(cell-error-name condition)
	107	(unreadable-slot-instance condition)))))
	108
584285fb	109	(defmethod compute-slot-reader-function :around ((slotd effective-virtual-slot-definition) &optional (signal-unbound-p t))
2bd78f93	110	(if (not (slot-readable-p slotd))
	111	#'(lambda (object)
	112	(error 'unreadable-slot :name (slot-definition-name slotd) :instance object))
	113	(let ((reader-function (call-next-method)))
	114	(cond
aed39f73	115	;; Don't create wrapper to signal unbound value
2bd78f93	116	((not signal-unbound-p) reader-function)
	117
	118	;; An explicit boundp function has been supplied
	119	((slot-boundp slotd 'boundp)
	120	(let ((unbound-value (slot-value slotd 'boundp)))
	121	#'(lambda (object)
	122	(let ((value (funcall reader-function object)))
	123	(if (eq value unbound-value)
	124	(slot-unbound (class-of object) object (slot-definition-name slotd))
	125	value)))))
	126
	127	;; A type unbound value exists
	128	((let ((unbound-method (find-applicable-type-method 'unbound-value
	129	(slot-definition-type slotd) nil)))
	130	(when unbound-method
	131	(let ((unbound-value (funcall unbound-method (slot-definition-type slotd))))
	132	#'(lambda (object)
	133	(let ((value (funcall reader-function object)))
	134	(if (eq value unbound-value)
	135	(slot-unbound (class-of object) object (slot-definition-name slotd))
	136	value)))))))
	137
	138	((let ((boundp-function (compute-slot-boundp-function slotd)))
	139	#'(lambda (object)
	140	(if (funcall boundp-function object)
	141	(funcall reader-function object)
	142	(slot-unbound (class-of object) object (slot-definition-name slotd))))))))))
584285fb	143
	144	(defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition) &optional signal-unbound-p)
	145	(declare (ignore signal-unbound-p))
2bd78f93	146	(slot-value slotd 'getter))
4e968638	147
	148	(defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definition))
	149	(cond
2bd78f93	150	;; Non readable slots are not bound per definition
	151	((not (slot-readable-p slotd))
	152	#'(lambda (object) (declare (ignore object)) nil))
	153
4e968638	154	;; An explicit boundp function has been supplied
	155	((slot-boundp slotd 'boundp) (slot-value slotd 'boundp))
	156
	157	;; An unbound value has been supplied
	158	((slot-boundp slotd 'unbound)
584285fb	159	(let ((reader-function (compute-slot-reader-function slotd nil))
4e968638	160	(unbound-value (slot-value slotd 'unbound)))
	161	#'(lambda (object)
	162	(not (eql (funcall reader-function object) unbound-value)))))
	163
	164	;; A type unbound value exists
	165	((let ((unbound-method (find-applicable-type-method 'unbound-value
	166	(slot-definition-type slotd) nil)))
	167	(when unbound-method
584285fb	168	(let ((reader-function (compute-slot-reader-function slotd nil))
4e968638	169	(unbound-value (funcall unbound-method (slot-definition-type slotd))))
	170	#'(lambda (object)
	171	(not (eql (funcall reader-function object) unbound-value)))))))
	172
	173	;; Slot has no unbound state
	174	(#'(lambda (object) (declare (ignore object)) t))))
	175
2bd78f93	176	(defmethod slot-writable-p ((slotd effective-virtual-slot-definition))
	177	(slot-boundp slotd 'setter))
	178
4e968638	179	(define-condition unwritable-slot (cell-error)
	180	((instance :reader unwritable-slot-instance :initarg :instance))
	181	(:report (lambda (condition stream)
	182	(format stream "~@<The slot ~S in the object ~S is not writable.~@:>"
	183	(cell-error-name condition)
	184	(unwritable-slot-instance condition)))))
	185
2bd78f93	186	(defmethod compute-slot-writer-function :around ((slotd effective-virtual-slot-definition))
	187	(if (not (slot-writable-p slotd))
	188	#'(lambda (value object)
	189	(declare (ignore value))
	190	(error 'unwritable-slot :name (slot-definition-name slotd) :instance object))
	191	(call-next-method)))
	192
4e968638	193	(defmethod compute-slot-writer-function ((slotd effective-virtual-slot-definition))
2bd78f93	194	(slot-value slotd 'setter))
	195
	196	(define-condition slot-can-not-be-unbound (cell-error)
	197	((instance :reader slot-can-not-be-unbound-instance :initarg :instance))
	198	(:report (lambda (condition stream)
	199	(format stream "~@<The slot ~S in the object ~S can not be made unbound.~@:>"
	200	(cell-error-name condition)
	201	(slot-can-not-be-unbound-instance condition)))))
4e968638	202
	203	(defmethod compute-slot-makunbound-function ((slotd effective-virtual-slot-definition))
	204	(cond
2bd78f93	205	((not (slot-writable-p slotd))
	206	#'(lambda (object)
	207	(error 'unwritable-slot :name (slot-definition-name slotd) :instance object)))
4e968638	208	((slot-boundp slotd 'makunbound) (slot-value slotd 'makunbound))
	209	((slot-boundp slotd 'unbound)
	210	#'(lambda (object)
	211	(funcall (slot-value slotd 'writer-function) (slot-value slotd 'unbound) object)))
	212	(t
	213	#'(lambda (object)
2bd78f93	214	(error 'slot-can-not-be-unbound :name (slot-definition-name slotd) :instance object)))))
4e968638	215
	216
	217	#-clisp
	218	(defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
584285fb	219	#?-(sbcl>= 0 9 15) ; Delayed to avoid recursive call of finalize-inheritanze
4e968638	220	(setf
	221	(slot-value slotd 'reader-function) (compute-slot-reader-function slotd)
	222	(slot-value slotd 'boundp-function) (compute-slot-boundp-function slotd)
	223	(slot-value slotd 'writer-function) (compute-slot-writer-function slotd)
	224	(slot-value slotd 'makunbound-function) (compute-slot-makunbound-function slotd))
	225
	226	#?-(sbcl>= 0 9 8)(initialize-internal-slot-gfs (slot-definition-name slotd)))
	227
	228
	229	#-clisp
	230	(defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf)
	231	nil)
	232
584285fb	233
4e968638	234	(defun slot-bound-in-some-p (instances slot)
	235	(find-if
	236	#'(lambda (ob)
	237	(and (slot-exists-p ob slot) (slot-boundp ob slot)))
	238	instances))
	239
	240	(defun most-specific-slot-value (instances slot &optional default)
	241	(let ((object (slot-bound-in-some-p instances slot)))
	242	(if object
	243	(slot-value object slot)
	244	default)))
	245
	246	(defun compute-most-specific-initargs (slotds slots)
	247	(loop
	248	for slot in slots
	249	as (slot-name initarg) = (if (atom slot)
	250	(list slot (intern (string slot) "KEYWORD"))
	251	slot)
	252	when (slot-bound-in-some-p slotds slot-name)
	253	nconc (list initarg (most-specific-slot-value slotds slot-name))))
	254
	255	(defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
	256	(typecase (first direct-slotds)
	257	(direct-virtual-slot-definition
	258	(nconc
	259	(compute-most-specific-initargs direct-slotds
	260	'(getter setter unbound boundp makunbound
	261	#?(or (sbcl>= 0 9 8) (featurep :clisp))
	262	(#?-(sbcl>= 0 9 10)type #?(sbcl>= 0 9 10)sb-pcl::%type :type)))
	263	(call-next-method)))
	264	(direct-special-slot-definition
	265	(append '(:special t) (call-next-method)))
	266	(t (call-next-method))))
	267
584285fb	268	#?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
4e968638	269	(defmethod slot-value-using-class
584285fb	270	((class virtual-slots-class) (object virtual-slots-object)
4e968638	271	(slotd effective-virtual-slot-definition))
584285fb	272	(funcall (slot-value slotd 'reader-function) object))
4e968638	273
584285fb	274	#?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
4e968638	275	(defmethod slot-boundp-using-class
584285fb	276	((class virtual-slots-class) (object virtual-slots-object)
4e968638	277	(slotd effective-virtual-slot-definition))
584285fb	278	(funcall (slot-value slotd 'boundp-function) object))
4e968638	279
584285fb	280	#?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
4e968638	281	(defmethod (setf slot-value-using-class)
584285fb	282	(value (class virtual-slots-class) (object virtual-slots-object)
4e968638	283	(slotd effective-virtual-slot-definition))
	284	(funcall (slot-value slotd 'writer-function) value object))
	285
	286	(defmethod slot-makunbound-using-class
584285fb	287	((class virtual-slots-class) (object virtual-slots-object)
4e968638	288	(slotd effective-virtual-slot-definition))
	289	(funcall (slot-value slotd 'makunbound-function) object))
	290
	291
584285fb	292	;; In CLISP and SBCL (0.9.15 or newler) a class may not have been
584285fb	293	;; finalized when update-slots are called. So to avoid the possibility
aed39f73	294	;; of finalize-instance being called recursivly we have to delay the
584285fb	295	;; initialization of slot functions until after an instance has been
	296	;; created.
	297	#?(or (sbcl>= 0 9 15) (featurep :clisp))
	298	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'reader-function)))
	299	(setf (slot-value slotd name) (compute-slot-reader-function slotd)))
4e968638	300
584285fb	301	#?(or (sbcl>= 0 9 15) (featurep :clisp))
	302	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'boundp-function)))
	303	(setf (slot-value slotd name) (compute-slot-boundp-function slotd)))
	304
	305	#?(or (sbcl>= 0 9 15) (featurep :clisp))
	306	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'writer-function)))
	307	(setf (slot-value slotd name) (compute-slot-writer-function slotd)))
	308
	309	#?(or (sbcl>= 0 9 15) (featurep :clisp))
	310	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'makunbound-function)))
	311	(setf (slot-value slotd name) (compute-slot-makunbound-function slotd)))
4e968638	312
4e968638	313
	314	(defmethod validate-superclass
	315	((class virtual-slots-class) (super standard-class))
	316	t)
	317
	318	(defmethod slot-definition-special ((slotd standard-direct-slot-definition))
	319	(declare (ignore slotd))
	320	nil)
	321
	322	(defmethod slot-definition-special ((slotd standard-effective-slot-definition))
	323	(declare (ignore slotd))
	324	nil)
	325
	326
4e968638	327	;;; To determine if a slot should be initialized with the initform,
4e968638	328	;;; CLISP checks whether it is unbound or not. This doesn't work with
aed39f73	329	;;; virtual slots that does not have an unbound state, so we have to
4e968638	330	;;; implement initform initialization in a way similar to how it is
	331	;;; done in PCL.
	332	#+clisp
	333	(defmethod shared-initialize ((object virtual-slots-object) names &rest initargs)
	334	(let* ((class (class-of object))
	335	(slotds (class-slots class))
	336	(keywords (loop
	337	for args on initargs by #'cddr
	338	collect (first args)))
	339	(names
	340	(loop
	341	for slotd in slotds
	342	as name = (slot-definition-name slotd)
	343	as initargs = (slot-definition-initargs slotd)
	344	as init-p = (and
	345	(or (eq names t) (find name names))
	346	(slot-definition-initfunction slotd)
	347	(not (intersection initargs keywords)))
	348	as virtual-p = (typep slotd 'effective-virtual-slot-definition)
	349	when (and init-p virtual-p)
	350	do (setf
	351	(slot-value-using-class class object slotd)
	352	(funcall (slot-definition-initfunction slotd)))
	353	when (and init-p (not virtual-p))
	354	collect name)))
	355
	356	(apply #'call-next-method object names initargs)))