[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
   boundp-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 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))))

(defmacro vsc-slot-x-using-class (x x-slot-name computer &key allow-string-fun-p)
  (let ((generic-name (intern (concatenate 'string
                                           "SLOT-" (string x) "-USING-CLASS"))))
    `(defmethod ,generic-name
         ((class virtual-slots-class) (object virtual-slots-object)
          (slotd effective-virtual-slot-definition))
       (unless (and (slot-boundp slotd ',x-slot-name)
                    ,@(when allow-string-fun-p
                         `((not
                            (stringp (slot-value slotd ',x-slot-name))))))
         (setf (slot-value slotd ',x-slot-name) (,computer slotd)))
       (funcall (slot-value slotd ',x-slot-name) object))))

(vsc-slot-x-using-class value getter compute-slot-reader-function
                        :allow-string-fun-p t)
(vsc-slot-x-using-class boundp boundp-function compute-slot-boundp-function)
(vsc-slot-x-using-class makunbound makunbound-function
                        compute-slot-makunbound-function)

(defmethod (setf slot-value-using-class) (value (class virtual-slots-class)
                                          (object virtual-slots-object)
                                          (slotd effective-virtual-slot-definition))
  (unless (slot-boundp slotd 'setter)
    (setf (slot-value slotd 'setter) (compute-slot-writer-function slotd)))
  (funcall (slot-value slotd 'setter) value 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
203681e2	50	boundp-function
584285fb	51	#+clisp(type :initarg :type :reader slot-definition-type)))
	52
	53	(defclass direct-special-slot-definition (standard-direct-slot-definition)
	54	((special :initarg :special :accessor slot-definition-special)))
	55
	56	(defclass effective-special-slot-definition (standard-effective-slot-definition)
	57	((special :initarg :special :accessor slot-definition-special)))
	58
	59	(defclass virtual-slots-object (standard-object)
	60	())
	61
2bd78f93	62	(defgeneric slot-readable-p (slotd))
2bd78f93	63	(defgeneric slot-writable-p (slotd))
584285fb	64	(defgeneric compute-slot-reader-function (slotd &optional signal-unbound-p))
4e968638	65	(defgeneric compute-slot-boundp-function (slotd))
	66	(defgeneric compute-slot-writer-function (slotd))
	67	(defgeneric compute-slot-makunbound-function (slotd))
	68
2bd78f93	69	(defmethod slot-readable-p ((slotd standard-effective-slot-definition))
	70	(declare (ignore slotd))
	71	t)
	72
	73	(defmethod slot-writable-p ((slotd standard-effective-slot-definition))
	74	(declare (ignore slotd))
	75	t)
	76
4e968638	77
	78	#+clisp
	79	(defmethod slot-definition-type ((slotd t))
	80	(clos:slot-definition-type slotd))
	81
	82
	83	(defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs)
	84	(cond
	85	((eq (getf initargs :allocation) :virtual)
	86	(find-class 'direct-virtual-slot-definition))
	87	((getf initargs :special)
	88	(find-class 'direct-special-slot-definition))
	89	(t (call-next-method))))
	90
	91	(defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs)
	92	(cond
	93	((eq (getf initargs :allocation) :virtual)
	94	(find-class 'effective-virtual-slot-definition))
	95	((getf initargs :special)
	96	(find-class 'effective-special-slot-definition))
	97	(t (call-next-method))))
	98
	99
2bd78f93	100	(defmethod slot-readable-p ((slotd effective-virtual-slot-definition))
	101	(slot-boundp slotd 'getter))
	102
4e968638	103	(define-condition unreadable-slot (cell-error)
	104	((instance :reader unreadable-slot-instance :initarg :instance))
	105	(:report (lambda (condition stream)
	106	(format stream "~@<The slot ~S in the object ~S is not readable.~@:>"
	107	(cell-error-name condition)
	108	(unreadable-slot-instance condition)))))
	109
584285fb	110	(defmethod compute-slot-reader-function :around ((slotd effective-virtual-slot-definition) &optional (signal-unbound-p t))
2bd78f93	111	(if (not (slot-readable-p slotd))
	112	#'(lambda (object)
	113	(error 'unreadable-slot :name (slot-definition-name slotd) :instance object))
	114	(let ((reader-function (call-next-method)))
	115	(cond
aed39f73	116	;; Don't create wrapper to signal unbound value
2bd78f93	117	((not signal-unbound-p) reader-function)
	118
	119	;; An explicit boundp function has been supplied
	120	((slot-boundp slotd 'boundp)
2f1ec179	121	(let ((boundp (slot-value slotd 'boundp)))
2bd78f93	122	#'(lambda (object)
2f1ec179	123	(if (not (funcall boundp object))
	124	(slot-unbound (class-of object) object (slot-definition-name slotd))
	125	(funcall reader-function object)))))
2bd78f93	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
c7a9d346	209	(symbol #'(lambda (value object) (funcall setter value object)))
c7a9d346	210	(list #'(lambda (value object)
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))
1d2032d4 RS	243	#?-(sbcl>= 0 9 8)
1d2032d4 RS	244	(initialize-internal-slot-gfs (slot-definition-name slotd)))
4e968638	245
	246
	247	#-clisp
	248	(defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf)
	249	nil)
	250
584285fb	251
4e968638	252	(defun slot-bound-in-some-p (instances slot)
	253	(find-if
	254	#'(lambda (ob)
	255	(and (slot-exists-p ob slot) (slot-boundp ob slot)))
	256	instances))
	257
	258	(defun most-specific-slot-value (instances slot &optional default)
	259	(let ((object (slot-bound-in-some-p instances slot)))
	260	(if object
	261	(slot-value object slot)
	262	default)))
	263
	264	(defun compute-most-specific-initargs (slotds slots)
	265	(loop
	266	for slot in slots
	267	as (slot-name initarg) = (if (atom slot)
	268	(list slot (intern (string slot) "KEYWORD"))
	269	slot)
	270	when (slot-bound-in-some-p slotds slot-name)
	271	nconc (list initarg (most-specific-slot-value slotds slot-name))))
	272
	273	(defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
	274	(typecase (first direct-slotds)
	275	(direct-virtual-slot-definition
	276	(nconc
	277	(compute-most-specific-initargs direct-slotds
	278	'(getter setter unbound boundp makunbound
	279	#?(or (sbcl>= 0 9 8) (featurep :clisp))
	280	(#?-(sbcl>= 0 9 10)type #?(sbcl>= 0 9 10)sb-pcl::%type :type)))
	281	(call-next-method)))
	282	(direct-special-slot-definition
	283	(append '(:special t) (call-next-method)))
	284	(t (call-next-method))))
	285
8f49b7a1	286	(defmacro vsc-slot-x-using-class (x x-slot-name computer &key allow-string-fun-p)
1d2032d4 RS	287	(let ((generic-name (intern (concatenate 'string
	288	"SLOT-" (string x) "-USING-CLASS"))))
	289	`(defmethod ,generic-name
	290	((class virtual-slots-class) (object virtual-slots-object)
	291	(slotd effective-virtual-slot-definition))
8f49b7a1 RS	292	(unless (and (slot-boundp slotd ',x-slot-name)
	293	,@(when allow-string-fun-p
	294	`((not
	295	(stringp (slot-value slotd ',x-slot-name))))))
1d2032d4 RS	296	(setf (slot-value slotd ',x-slot-name) (,computer slotd)))
	297	(funcall (slot-value slotd ',x-slot-name) object))))
	298
8f49b7a1 RS	299	(vsc-slot-x-using-class value getter compute-slot-reader-function
8f49b7a1 RS	300	:allow-string-fun-p t)
1d2032d4 RS	301	(vsc-slot-x-using-class boundp boundp-function compute-slot-boundp-function)
	302	(vsc-slot-x-using-class makunbound makunbound-function
	303	compute-slot-makunbound-function)
	304
	305	(defmethod (setf slot-value-using-class) (value (class virtual-slots-class)
	306	(object virtual-slots-object)
	307	(slotd effective-virtual-slot-definition))
	308	(unless (slot-boundp slotd 'setter)
	309	(setf (slot-value slotd 'setter) (compute-slot-writer-function slotd)))
	310	(funcall (slot-value slotd 'setter) value object))
4e968638	311
584285fb	312	;; In CLISP and SBCL (0.9.15 or newler) a class may not have been
584285fb	313	;; finalized when update-slots are called. So to avoid the possibility
aed39f73	314	;; of finalize-instance being called recursivly we have to delay the
584285fb	315	;; initialization of slot functions until after an instance has been
584285fb	316	;; created.
0bbf3105	317	;; 2007-11-08: done this for all implementations
0bbf3105	318	;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb	319	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'reader-function)))
e3f4fceb	320	(declare (ignore class))
584285fb	321	(setf (slot-value slotd name) (compute-slot-reader-function slotd)))
4e968638	322
0bbf3105	323	;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb	324	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'boundp-function)))
e3f4fceb	325	(declare (ignore class))
584285fb	326	(setf (slot-value slotd name) (compute-slot-boundp-function slotd)))
584285fb	327
0bbf3105	328	;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb	329	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'writer-function)))
e3f4fceb	330	(declare (ignore class))
584285fb	331	(setf (slot-value slotd name) (compute-slot-writer-function slotd)))
584285fb	332
0bbf3105	333	;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb	334	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'makunbound-function)))
e3f4fceb	335	(declare (ignore class))
584285fb	336	(setf (slot-value slotd name) (compute-slot-makunbound-function slotd)))
4e968638	337
4e968638	338
	339	(defmethod validate-superclass
	340	((class virtual-slots-class) (super standard-class))
	341	t)
	342
	343	(defmethod slot-definition-special ((slotd standard-direct-slot-definition))
	344	(declare (ignore slotd))
	345	nil)
	346
	347	(defmethod slot-definition-special ((slotd standard-effective-slot-definition))
	348	(declare (ignore slotd))
	349	nil)
	350
	351
4e968638	352	;;; To determine if a slot should be initialized with the initform,
4e968638	353	;;; CLISP checks whether it is unbound or not. This doesn't work with
aed39f73	354	;;; virtual slots that does not have an unbound state, so we have to
4e968638	355	;;; implement initform initialization in a way similar to how it is
	356	;;; done in PCL.
	357	#+clisp
	358	(defmethod shared-initialize ((object virtual-slots-object) names &rest initargs)
	359	(let* ((class (class-of object))
	360	(slotds (class-slots class))
	361	(keywords (loop
	362	for args on initargs by #'cddr
	363	collect (first args)))
	364	(names
	365	(loop
	366	for slotd in slotds
	367	as name = (slot-definition-name slotd)
	368	as initargs = (slot-definition-initargs slotd)
	369	as init-p = (and
	370	(or (eq names t) (find name names))
	371	(slot-definition-initfunction slotd)
	372	(not (intersection initargs keywords)))
	373	as virtual-p = (typep slotd 'effective-virtual-slot-definition)
	374	when (and init-p virtual-p)
	375	do (setf
	376	(slot-value-using-class class object slotd)
	377	(funcall (slot-definition-initfunction slotd)))
	378	when (and init-p (not virtual-p))
	379	collect name)))
	380
	381	(apply #'call-next-method object names initargs)))