[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)
   reader-function
   makunbound-function
   boundp-function
   writer-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))))))
         (let ((computed (,computer slotd)))
           (setf (slot-value slotd ',x-slot-name) computed)))
       (funcall (slot-value slotd ',x-slot-name) object))))

(vsc-slot-x-using-class value reader-function
                        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 'writer-function)
    (setf (slot-value slotd 'writer-function)
          (compute-slot-writer-function slotd)))
  (funcall (slot-value slotd 'writer-function) 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)
8fb57952	46	reader-function
584285fb	47	makunbound-function
203681e2	48	boundp-function
8fb57952	49	writer-function
584285fb	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))
1d2032d4 RS	242	#?-(sbcl>= 0 9 8)
1d2032d4 RS	243	(initialize-internal-slot-gfs (slot-definition-name slotd)))
4e968638	244
	245
	246	#-clisp
	247	(defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf)
	248	nil)
	249
584285fb	250
4e968638	251	(defun slot-bound-in-some-p (instances slot)
	252	(find-if
	253	#'(lambda (ob)
	254	(and (slot-exists-p ob slot) (slot-boundp ob slot)))
	255	instances))
	256
	257	(defun most-specific-slot-value (instances slot &optional default)
	258	(let ((object (slot-bound-in-some-p instances slot)))
	259	(if object
	260	(slot-value object slot)
	261	default)))
	262
	263	(defun compute-most-specific-initargs (slotds slots)
	264	(loop
	265	for slot in slots
	266	as (slot-name initarg) = (if (atom slot)
	267	(list slot (intern (string slot) "KEYWORD"))
	268	slot)
	269	when (slot-bound-in-some-p slotds slot-name)
	270	nconc (list initarg (most-specific-slot-value slotds slot-name))))
	271
	272	(defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
	273	(typecase (first direct-slotds)
	274	(direct-virtual-slot-definition
	275	(nconc
	276	(compute-most-specific-initargs direct-slotds
	277	'(getter setter unbound boundp makunbound
	278	#?(or (sbcl>= 0 9 8) (featurep :clisp))
	279	(#?-(sbcl>= 0 9 10)type #?(sbcl>= 0 9 10)sb-pcl::%type :type)))
	280	(call-next-method)))
	281	(direct-special-slot-definition
	282	(append '(:special t) (call-next-method)))
	283	(t (call-next-method))))
	284
8fb57952	285	(defmacro vsc-slot-x-using-class (x x-slot-name computer &key allow-string-fun-p)
1d2032d4 RS	286	(let ((generic-name (intern (concatenate 'string
1d2032d4 RS	287	"SLOT-" (string x) "-USING-CLASS"))))
8fb57952 RS	288	`(defmethod ,generic-name
8fb57952 RS	289	((class virtual-slots-class) (object virtual-slots-object)
1d2032d4	290	(slotd effective-virtual-slot-definition))
8f49b7a1 RS	291	(unless (and (slot-boundp slotd ',x-slot-name)
8f49b7a1 RS	292	,@(when allow-string-fun-p
8fb57952 RS	293	`((not (stringp (slot-value slotd ',x-slot-name))))))
	294	(let ((computed (,computer slotd)))
	295	(setf (slot-value slotd ',x-slot-name) computed)))
	296	(funcall (slot-value slotd ',x-slot-name) object))))
b9f34364	297
8fb57952 RS	298	(vsc-slot-x-using-class value reader-function
8fb57952 RS	299	compute-slot-reader-function :allow-string-fun-p t)
1d2032d4 RS	300	(vsc-slot-x-using-class boundp boundp-function compute-slot-boundp-function)
	301	(vsc-slot-x-using-class makunbound makunbound-function
	302	compute-slot-makunbound-function)
	303
8fb57952 RS	304	(defmethod (setf slot-value-using-class)
	305	(value
	306	(class virtual-slots-class) (object virtual-slots-object)
	307	(slotd effective-virtual-slot-definition))
	308	(unless (slot-boundp slotd 'writer-function)
	309	(setf (slot-value slotd 'writer-function)
	310	(compute-slot-writer-function slotd)))
	311	(funcall (slot-value slotd 'writer-function) value object))
	312
584285fb	313	;; In CLISP and SBCL (0.9.15 or newler) a class may not have been
584285fb	314	;; finalized when update-slots are called. So to avoid the possibility
aed39f73	315	;; of finalize-instance being called recursivly we have to delay the
584285fb	316	;; initialization of slot functions until after an instance has been
584285fb	317	;; created.
0bbf3105	318	;; 2007-11-08: done this for all implementations
0bbf3105	319	;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb	320	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'reader-function)))
e3f4fceb	321	(declare (ignore class))
584285fb	322	(setf (slot-value slotd name) (compute-slot-reader-function slotd)))
4e968638	323
0bbf3105	324	;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb	325	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'boundp-function)))
e3f4fceb	326	(declare (ignore class))
584285fb	327	(setf (slot-value slotd name) (compute-slot-boundp-function slotd)))
584285fb	328
0bbf3105	329	;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb	330	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'writer-function)))
e3f4fceb	331	(declare (ignore class))
584285fb	332	(setf (slot-value slotd name) (compute-slot-writer-function slotd)))
584285fb	333
0bbf3105	334	;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb	335	(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'makunbound-function)))
e3f4fceb	336	(declare (ignore class))
584285fb	337	(setf (slot-value slotd name) (compute-slot-makunbound-function slotd)))
4e968638	338
4e968638	339
	340	(defmethod validate-superclass
	341	((class virtual-slots-class) (super standard-class))
	342	t)
	343
	344	(defmethod slot-definition-special ((slotd standard-direct-slot-definition))
	345	(declare (ignore slotd))
	346	nil)
	347
	348	(defmethod slot-definition-special ((slotd standard-effective-slot-definition))
	349	(declare (ignore slotd))
	350	nil)
	351
	352
4e968638	353	;;; To determine if a slot should be initialized with the initform,
4e968638	354	;;; CLISP checks whether it is unbound or not. This doesn't work with
aed39f73	355	;;; virtual slots that does not have an unbound state, so we have to
4e968638	356	;;; implement initform initialization in a way similar to how it is
	357	;;; done in PCL.
	358	#+clisp
	359	(defmethod shared-initialize ((object virtual-slots-object) names &rest initargs)
	360	(let* ((class (class-of object))
	361	(slotds (class-slots class))
	362	(keywords (loop
	363	for args on initargs by #'cddr
	364	collect (first args)))
	365	(names
	366	(loop
	367	for slotd in slotds
	368	as name = (slot-definition-name slotd)
	369	as initargs = (slot-definition-initargs slotd)
	370	as init-p = (and
	371	(or (eq names t) (find name names))
	372	(slot-definition-initfunction slotd)
	373	(not (intersection initargs keywords)))
	374	as virtual-p = (typep slotd 'effective-virtual-slot-definition)
	375	when (and init-p virtual-p)
	376	do (setf
	377	(slot-value-using-class class object slotd)
	378	(funcall (slot-definition-initfunction slotd)))
	379	when (and init-p (not virtual-p))
	380	collect name)))
	381
	382	(apply #'call-next-method object names initargs)))