[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.11 2007-11-08 13:49:26 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 ((boundp (slot-value slotd 'boundp)))
	  #'(lambda (object)
	      (if (not (funcall boundp object))
		  (slot-unbound (class-of object) object (slot-definition-name slotd))
		(funcall reader-function object)))))
       
       ;; 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 (value object) (funcall setter value object)))
      (list #'(lambda (value object)
		(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
  #+nil ;; 2007-11-08: done this for all implementations
  (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.
;; 2007-11-08: done this for all implementations
;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'reader-function)))
  (declare (ignore class))
  (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)))
  (declare (ignore class))
  (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)))
  (declare (ignore class))
  (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)))
  (declare (ignore class))
  (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
0bbf3105	23	;; $Id: virtual-slots.lisp,v 1.11 2007-11-08 13:49:26 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)
2f1ec179	120	(let ((boundp (slot-value slotd 'boundp)))
2bd78f93	121	#'(lambda (object)
2f1ec179	122	(if (not (funcall boundp object))
	123	(slot-unbound (class-of object) object (slot-definition-name slotd))
	124	(funcall reader-function object)))))
2bd78f93	125
	126	;; A type unbound value exists
	127	((let ((unbound-method (find-applicable-type-method 'unbound-value
	128	(slot-definition-type slotd) nil)))
	129	(when unbound-method
	130	(let ((unbound-value (funcall unbound-method (slot-definition-type slotd))))
	131	#'(lambda (object)
	132	(let ((value (funcall reader-function object)))
	133	(if (eq value unbound-value)
	134	(slot-unbound (class-of object) object (slot-definition-name slotd))
	135	value)))))))
	136
	137	((let ((boundp-function (compute-slot-boundp-function slotd)))
	138	#'(lambda (object)
	139	(if (funcall boundp-function object)
	140	(funcall reader-function object)
	141	(slot-unbound (class-of object) object (slot-definition-name slotd))))))))))
584285fb	142
	143	(defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition) &optional signal-unbound-p)
	144	(declare (ignore signal-unbound-p))
b977e63b	145	(let ((getter (slot-value slotd 'getter)))
	146	#-sbcl getter
	147	#+sbcl
	148	(etypecase getter
	149	(symbol #'(lambda (object) (funcall getter object)))
	150	(function getter))))
4e968638	151
	152	(defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definition))
	153	(cond
2bd78f93	154	;; Non readable slots are not bound per definition
	155	((not (slot-readable-p slotd))
	156	#'(lambda (object) (declare (ignore object)) nil))
	157
4e968638	158	;; An explicit boundp function has been supplied
b977e63b	159	((slot-boundp slotd 'boundp)
	160	(let ((boundp (slot-value slotd 'boundp)))
	161	#-sbcl boundp
	162	#+sbcl
	163	(etypecase boundp
	164	(symbol #'(lambda (object) (funcall boundp object)))
	165	(function boundp))))
	166
4e968638	167	;; An unbound value has been supplied
4e968638	168	((slot-boundp slotd 'unbound)
584285fb	169	(let ((reader-function (compute-slot-reader-function slotd nil))
4e968638	170	(unbound-value (slot-value slotd 'unbound)))
	171	#'(lambda (object)
	172	(not (eql (funcall reader-function object) unbound-value)))))
	173
	174	;; A type unbound value exists
	175	((let ((unbound-method (find-applicable-type-method 'unbound-value
	176	(slot-definition-type slotd) nil)))
	177	(when unbound-method
584285fb	178	(let ((reader-function (compute-slot-reader-function slotd nil))
4e968638	179	(unbound-value (funcall unbound-method (slot-definition-type slotd))))
	180	#'(lambda (object)
	181	(not (eql (funcall reader-function object) unbound-value)))))))
	182
	183	;; Slot has no unbound state
	184	(#'(lambda (object) (declare (ignore object)) t))))
	185
2bd78f93	186	(defmethod slot-writable-p ((slotd effective-virtual-slot-definition))
	187	(slot-boundp slotd 'setter))
	188
4e968638	189	(define-condition unwritable-slot (cell-error)
	190	((instance :reader unwritable-slot-instance :initarg :instance))
	191	(:report (lambda (condition stream)
	192	(format stream "~@<The slot ~S in the object ~S is not writable.~@:>"
	193	(cell-error-name condition)
	194	(unwritable-slot-instance condition)))))
	195
2bd78f93	196	(defmethod compute-slot-writer-function :around ((slotd effective-virtual-slot-definition))
	197	(if (not (slot-writable-p slotd))
	198	#'(lambda (value object)
	199	(declare (ignore value))
	200	(error 'unwritable-slot :name (slot-definition-name slotd) :instance object))
	201	(call-next-method)))
	202
4e968638	203	(defmethod compute-slot-writer-function ((slotd effective-virtual-slot-definition))
b977e63b	204	(let ((setter (slot-value slotd 'setter)))
	205	#-sbcl setter
	206	#+sbcl
	207	(etypecase setter
c7a9d346	208	(symbol #'(lambda (value object) (funcall setter value object)))
c7a9d346	209	(list #'(lambda (value object)
9f851ae5	210	(funcall setter value object)))
b977e63b	211	(function setter))))
2bd78f93	212
	213	(define-condition slot-can-not-be-unbound (cell-error)
	214	((instance :reader slot-can-not-be-unbound-instance :initarg :instance))
	215	(:report (lambda (condition stream)
	216	(format stream "~@<The slot ~S in the object ~S can not be made unbound.~@:>"
	217	(cell-error-name condition)
	218	(slot-can-not-be-unbound-instance condition)))))
4e968638	219
	220	(defmethod compute-slot-makunbound-function ((slotd effective-virtual-slot-definition))
	221	(cond
2bd78f93	222	((not (slot-writable-p slotd))
	223	#'(lambda (object)
	224	(error 'unwritable-slot :name (slot-definition-name slotd) :instance object)))
b977e63b	225	((slot-boundp slotd 'makunbound)
	226	(let ((makunbound (slot-value slotd 'makunbound)))
	227	#-sbcl makunbound
	228	#+sbcl
	229	(etypecase makunbound
	230	(symbol #'(lambda (object) (funcall makunbound object)))
	231	(function makunbound))))
4e968638	232	((slot-boundp slotd 'unbound)
	233	#'(lambda (object)
	234	(funcall (slot-value slotd 'writer-function) (slot-value slotd 'unbound) object)))
	235	(t
	236	#'(lambda (object)
2bd78f93	237	(error 'slot-can-not-be-unbound :name (slot-definition-name slotd) :instance object)))))
4e968638	238
	239
	240	#-clisp
	241	(defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
0bbf3105	242	;; #?-(sbcl>= 0 9 15) ; Delayed to avoid recursive call of finalize-inheritanze
0bbf3105	243	#+nil ;; 2007-11-08: done this for all implementations
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
584285fb	320	;; created.
0bbf3105	321	;; 2007-11-08: done this for all implementations
0bbf3105	322	;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb	323	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'reader-function)))
e3f4fceb	324	(declare (ignore class))
584285fb	325	(setf (slot-value slotd name) (compute-slot-reader-function slotd)))
4e968638	326
0bbf3105	327	;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb	328	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'boundp-function)))
e3f4fceb	329	(declare (ignore class))
584285fb	330	(setf (slot-value slotd name) (compute-slot-boundp-function slotd)))
584285fb	331
0bbf3105	332	;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb	333	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'writer-function)))
e3f4fceb	334	(declare (ignore class))
584285fb	335	(setf (slot-value slotd name) (compute-slot-writer-function slotd)))
584285fb	336
0bbf3105	337	;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb	338	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'makunbound-function)))
e3f4fceb	339	(declare (ignore class))
584285fb	340	(setf (slot-value slotd name) (compute-slot-makunbound-function slotd)))
4e968638	341
4e968638	342
	343	(defmethod validate-superclass
	344	((class virtual-slots-class) (super standard-class))
	345	t)
	346
	347	(defmethod slot-definition-special ((slotd standard-direct-slot-definition))
	348	(declare (ignore slotd))
	349	nil)
	350
	351	(defmethod slot-definition-special ((slotd standard-effective-slot-definition))
	352	(declare (ignore slotd))
	353	nil)
	354
	355
4e968638	356	;;; To determine if a slot should be initialized with the initform,
4e968638	357	;;; CLISP checks whether it is unbound or not. This doesn't work with
aed39f73	358	;;; virtual slots that does not have an unbound state, so we have to
4e968638	359	;;; implement initform initialization in a way similar to how it is
	360	;;; done in PCL.
	361	#+clisp
	362	(defmethod shared-initialize ((object virtual-slots-object) names &rest initargs)
	363	(let* ((class (class-of object))
	364	(slotds (class-slots class))
	365	(keywords (loop
	366	for args on initargs by #'cddr
	367	collect (first args)))
	368	(names
	369	(loop
	370	for slotd in slotds
	371	as name = (slot-definition-name slotd)
	372	as initargs = (slot-definition-initargs slotd)
	373	as init-p = (and
	374	(or (eq names t) (find name names))
	375	(slot-definition-initfunction slotd)
	376	(not (intersection initargs keywords)))
	377	as virtual-p = (typep slotd 'effective-virtual-slot-definition)
	378	when (and init-p virtual-p)
	379	do (setf
	380	(slot-value-using-class class object slotd)
	381	(funcall (slot-definition-initfunction slotd)))
	382	when (and init-p (not virtual-p))
	383	collect name)))
	384
	385	(apply #'call-next-method object names initargs)))