[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.6 2007-01-02 16:04:57 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))
  (let ((getter (slot-value slotd 'getter)))
    #-sbcl getter
    #+sbcl
    (etypecase getter
      (symbol #'(lambda (object) (funcall getter object)))
      (function 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)
    (let ((boundp (slot-value slotd 'boundp)))
      #-sbcl boundp
      #+sbcl
      (etypecase boundp
	(symbol #'(lambda (object) (funcall boundp object)))
	(function 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))
  (let ((setter (slot-value slotd 'setter)))
    #-sbcl setter
    #+sbcl
    (etypecase setter
      (symbol #'(lambda (object value) (funcall setter object value)))
      (list #'(lambda (object value)
		(funcall setter value object)))
      (function 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)
    (let ((makunbound (slot-value slotd 'makunbound)))
      #-sbcl makunbound
      #+sbcl
      (etypecase makunbound
	(symbol #'(lambda (object) (funcall makunbound object)))
	(function 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
9f851ae5	23	;; $Id: virtual-slots.lisp,v 1.6 2007-01-02 16:04:57 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))
b977e63b	146	(let ((getter (slot-value slotd 'getter)))
	147	#-sbcl getter
	148	#+sbcl
	149	(etypecase getter
	150	(symbol #'(lambda (object) (funcall getter object)))
	151	(function getter))))
4e968638	152
	153	(defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definition))
	154	(cond
2bd78f93	155	;; Non readable slots are not bound per definition
	156	((not (slot-readable-p slotd))
	157	#'(lambda (object) (declare (ignore object)) nil))
	158
4e968638	159	;; An explicit boundp function has been supplied
b977e63b	160	((slot-boundp slotd 'boundp)
	161	(let ((boundp (slot-value slotd 'boundp)))
	162	#-sbcl boundp
	163	#+sbcl
	164	(etypecase boundp
	165	(symbol #'(lambda (object) (funcall boundp object)))
	166	(function boundp))))
	167
4e968638	168	;; An unbound value has been supplied
4e968638	169	((slot-boundp slotd 'unbound)
584285fb	170	(let ((reader-function (compute-slot-reader-function slotd nil))
4e968638	171	(unbound-value (slot-value slotd 'unbound)))
	172	#'(lambda (object)
	173	(not (eql (funcall reader-function object) unbound-value)))))
	174
	175	;; A type unbound value exists
	176	((let ((unbound-method (find-applicable-type-method 'unbound-value
	177	(slot-definition-type slotd) nil)))
	178	(when unbound-method
584285fb	179	(let ((reader-function (compute-slot-reader-function slotd nil))
4e968638	180	(unbound-value (funcall unbound-method (slot-definition-type slotd))))
	181	#'(lambda (object)
	182	(not (eql (funcall reader-function object) unbound-value)))))))
	183
	184	;; Slot has no unbound state
	185	(#'(lambda (object) (declare (ignore object)) t))))
	186
2bd78f93	187	(defmethod slot-writable-p ((slotd effective-virtual-slot-definition))
	188	(slot-boundp slotd 'setter))
	189
4e968638	190	(define-condition unwritable-slot (cell-error)
	191	((instance :reader unwritable-slot-instance :initarg :instance))
	192	(:report (lambda (condition stream)
	193	(format stream "~@<The slot ~S in the object ~S is not writable.~@:>"
	194	(cell-error-name condition)
	195	(unwritable-slot-instance condition)))))
	196
2bd78f93	197	(defmethod compute-slot-writer-function :around ((slotd effective-virtual-slot-definition))
	198	(if (not (slot-writable-p slotd))
	199	#'(lambda (value object)
	200	(declare (ignore value))
	201	(error 'unwritable-slot :name (slot-definition-name slotd) :instance object))
	202	(call-next-method)))
	203
4e968638	204	(defmethod compute-slot-writer-function ((slotd effective-virtual-slot-definition))
b977e63b	205	(let ((setter (slot-value slotd 'setter)))
	206	#-sbcl setter
	207	#+sbcl
	208	(etypecase setter
	209	(symbol #'(lambda (object value) (funcall setter object value)))
9f851ae5	210	(list #'(lambda (object value)
9f851ae5	211	(funcall setter value object)))
b977e63b	212	(function setter))))
2bd78f93	213
	214	(define-condition slot-can-not-be-unbound (cell-error)
	215	((instance :reader slot-can-not-be-unbound-instance :initarg :instance))
	216	(:report (lambda (condition stream)
	217	(format stream "~@<The slot ~S in the object ~S can not be made unbound.~@:>"
	218	(cell-error-name condition)
	219	(slot-can-not-be-unbound-instance condition)))))
4e968638	220
	221	(defmethod compute-slot-makunbound-function ((slotd effective-virtual-slot-definition))
	222	(cond
2bd78f93	223	((not (slot-writable-p slotd))
	224	#'(lambda (object)
	225	(error 'unwritable-slot :name (slot-definition-name slotd) :instance object)))
b977e63b	226	((slot-boundp slotd 'makunbound)
	227	(let ((makunbound (slot-value slotd 'makunbound)))
	228	#-sbcl makunbound
	229	#+sbcl
	230	(etypecase makunbound
	231	(symbol #'(lambda (object) (funcall makunbound object)))
	232	(function makunbound))))
4e968638	233	((slot-boundp slotd 'unbound)
	234	#'(lambda (object)
	235	(funcall (slot-value slotd 'writer-function) (slot-value slotd 'unbound) object)))
	236	(t
	237	#'(lambda (object)
2bd78f93	238	(error 'slot-can-not-be-unbound :name (slot-definition-name slotd) :instance object)))))
4e968638	239
	240
	241	#-clisp
	242	(defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
584285fb	243	#?-(sbcl>= 0 9 15) ; Delayed to avoid recursive call of finalize-inheritanze
4e968638	244	(setf
	245	(slot-value slotd 'reader-function) (compute-slot-reader-function slotd)
	246	(slot-value slotd 'boundp-function) (compute-slot-boundp-function slotd)
	247	(slot-value slotd 'writer-function) (compute-slot-writer-function slotd)
	248	(slot-value slotd 'makunbound-function) (compute-slot-makunbound-function slotd))
	249
	250	#?-(sbcl>= 0 9 8)(initialize-internal-slot-gfs (slot-definition-name slotd)))
	251
	252
	253	#-clisp
	254	(defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf)
	255	nil)
	256
584285fb	257
4e968638	258	(defun slot-bound-in-some-p (instances slot)
	259	(find-if
	260	#'(lambda (ob)
	261	(and (slot-exists-p ob slot) (slot-boundp ob slot)))
	262	instances))
	263
	264	(defun most-specific-slot-value (instances slot &optional default)
	265	(let ((object (slot-bound-in-some-p instances slot)))
	266	(if object
	267	(slot-value object slot)
	268	default)))
	269
	270	(defun compute-most-specific-initargs (slotds slots)
	271	(loop
	272	for slot in slots
	273	as (slot-name initarg) = (if (atom slot)
	274	(list slot (intern (string slot) "KEYWORD"))
	275	slot)
	276	when (slot-bound-in-some-p slotds slot-name)
	277	nconc (list initarg (most-specific-slot-value slotds slot-name))))
	278
	279	(defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
	280	(typecase (first direct-slotds)
	281	(direct-virtual-slot-definition
	282	(nconc
	283	(compute-most-specific-initargs direct-slotds
	284	'(getter setter unbound boundp makunbound
	285	#?(or (sbcl>= 0 9 8) (featurep :clisp))
	286	(#?-(sbcl>= 0 9 10)type #?(sbcl>= 0 9 10)sb-pcl::%type :type)))
	287	(call-next-method)))
	288	(direct-special-slot-definition
	289	(append '(:special t) (call-next-method)))
	290	(t (call-next-method))))
	291
584285fb	292	#?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
4e968638	293	(defmethod slot-value-using-class
584285fb	294	((class virtual-slots-class) (object virtual-slots-object)
4e968638	295	(slotd effective-virtual-slot-definition))
584285fb	296	(funcall (slot-value slotd 'reader-function) object))
4e968638	297
584285fb	298	#?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
4e968638	299	(defmethod slot-boundp-using-class
584285fb	300	((class virtual-slots-class) (object virtual-slots-object)
4e968638	301	(slotd effective-virtual-slot-definition))
584285fb	302	(funcall (slot-value slotd 'boundp-function) object))
4e968638	303
584285fb	304	#?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
4e968638	305	(defmethod (setf slot-value-using-class)
584285fb	306	(value (class virtual-slots-class) (object virtual-slots-object)
4e968638	307	(slotd effective-virtual-slot-definition))
	308	(funcall (slot-value slotd 'writer-function) value object))
	309
	310	(defmethod slot-makunbound-using-class
584285fb	311	((class virtual-slots-class) (object virtual-slots-object)
4e968638	312	(slotd effective-virtual-slot-definition))
	313	(funcall (slot-value slotd 'makunbound-function) object))
	314
	315
584285fb	316	;; In CLISP and SBCL (0.9.15 or newler) a class may not have been
584285fb	317	;; finalized when update-slots are called. So to avoid the possibility
aed39f73	318	;; of finalize-instance being called recursivly we have to delay the
584285fb	319	;; initialization of slot functions until after an instance has been
	320	;; created.
	321	#?(or (sbcl>= 0 9 15) (featurep :clisp))
	322	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'reader-function)))
	323	(setf (slot-value slotd name) (compute-slot-reader-function slotd)))
4e968638	324
584285fb	325	#?(or (sbcl>= 0 9 15) (featurep :clisp))
	326	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'boundp-function)))
	327	(setf (slot-value slotd name) (compute-slot-boundp-function slotd)))
	328
	329	#?(or (sbcl>= 0 9 15) (featurep :clisp))
	330	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'writer-function)))
	331	(setf (slot-value slotd name) (compute-slot-writer-function slotd)))
	332
	333	#?(or (sbcl>= 0 9 15) (featurep :clisp))
	334	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'makunbound-function)))
	335	(setf (slot-value slotd name) (compute-slot-makunbound-function slotd)))
4e968638	336
4e968638	337
	338	(defmethod validate-superclass
	339	((class virtual-slots-class) (super standard-class))
	340	t)
	341
	342	(defmethod slot-definition-special ((slotd standard-direct-slot-definition))
	343	(declare (ignore slotd))
	344	nil)
	345
	346	(defmethod slot-definition-special ((slotd standard-effective-slot-definition))
	347	(declare (ignore slotd))
	348	nil)
	349
	350
4e968638	351	;;; To determine if a slot should be initialized with the initform,
4e968638	352	;;; CLISP checks whether it is unbound or not. This doesn't work with
aed39f73	353	;;; virtual slots that does not have an unbound state, so we have to
4e968638	354	;;; implement initform initialization in a way similar to how it is
	355	;;; done in PCL.
	356	#+clisp
	357	(defmethod shared-initialize ((object virtual-slots-object) names &rest initargs)
	358	(let* ((class (class-of object))
	359	(slotds (class-slots class))
	360	(keywords (loop
	361	for args on initargs by #'cddr
	362	collect (first args)))
	363	(names
	364	(loop
	365	for slotd in slotds
	366	as name = (slot-definition-name slotd)
	367	as initargs = (slot-definition-initargs slotd)
	368	as init-p = (and
	369	(or (eq names t) (find name names))
	370	(slot-definition-initfunction slotd)
	371	(not (intersection initargs keywords)))
	372	as virtual-p = (typep slotd 'effective-virtual-slot-definition)
	373	when (and init-p virtual-p)
	374	do (setf
	375	(slot-value-using-class class object slotd)
	376	(funcall (slot-definition-initfunction slotd)))
	377	when (and init-p (not virtual-p))
	378	collect name)))
	379
	380	(apply #'call-next-method object names initargs)))