--- /dev/null
+;; 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: proxy.lisp,v 1.1 2006-04-25 20:49:16 espen Exp $
+
+(in-package "GFFI")
+
+
+;;;; Proxy cache
+
+(defvar *instance-cache* (make-hash-table :test #'eql))
+
+(defun cache-instance (instance &optional (weak-ref t))
+ (setf
+ (gethash (pointer-address (foreign-location instance)) *instance-cache*)
+ (if weak-ref
+ (make-weak-pointer instance)
+ instance)))
+
+(defun find-cached-instance (location)
+ (let ((ref (gethash (pointer-address location) *instance-cache*)))
+ (when ref
+ (if (weak-pointer-p ref)
+ (weak-pointer-value ref)
+ ref))))
+
+(defun instance-cached-p (location)
+ (gethash (pointer-address location) *instance-cache*))
+
+(defun remove-cached-instance (location)
+ (remhash (pointer-address location) *instance-cache*))
+
+;; For debuging
+(defun list-cached-instances ()
+ (let ((instances ()))
+ (maphash #'(lambda (location ref)
+ (declare (ignore location))
+ (push ref instances))
+ *instance-cache*)
+ instances))
+
+;; Instances that gets invalidated tend to be short lived, but created
+;; in large numbers. So we're keeping them in a hash table to be able
+;; to reuse them (and thus reduce consing)
+(defvar *invalidated-instance-cache* (make-hash-table :test #'eql))
+
+(defun cache-invalidated-instance (instance)
+ (push instance
+ (gethash (class-of instance) *invalidated-instance-cache*)))
+
+(defun find-invalidated-instance (class)
+ (when (gethash class *invalidated-instance-cache*)
+ (pop (gethash class *invalidated-instance-cache*))))
+
+(defun list-invalidated-instances ()
+ (let ((instances ()))
+ (maphash #'(lambda (location ref)
+ (declare (ignore location))
+ (push ref instances))
+ *invalidated-instance-cache*)
+ instances))
+
+
+
+;;;; Proxy for alien instances
+
+#+clisp
+(defvar *foreign-instance-locations* (make-hash-table :weak :key))
+
+;; TODO: add a ref-counted-proxy subclass
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defclass proxy (virtual-slots-object)
+ (#-clisp(location :special t :type pointer))
+ (:metaclass virtual-slots-class)))
+
+(defgeneric instance-finalizer (instance))
+(defgeneric reference-function (class))
+(defgeneric unreference-function (class))
+(defgeneric invalidate-instance (instance &optional finalize-p))
+(defgeneric allocate-foreign (object &key &allow-other-keys))
+
+(defun foreign-location (instance)
+ #-clisp(slot-value instance 'location)
+ #+clisp(gethash instance *foreign-instance-locations*))
+
+(defun (setf foreign-location) (location instance)
+ #-clisp(setf (slot-value instance 'location) location)
+ #+clisp(setf (gethash instance *foreign-instance-locations*) location))
+
+(defun proxy-valid-p (instance)
+ #-clisp(slot-boundp instance 'location)
+ #+clisp(and (gethash instance *foreign-instance-locations*) t))
+
+(defmethod reference-function ((name symbol))
+ (reference-function (find-class name)))
+
+(defmethod unreference-function ((name symbol))
+ (unreference-function (find-class name)))
+
+(defmethod print-object ((instance proxy) stream)
+ (print-unreadable-object (instance stream :type t :identity nil)
+ (if (proxy-valid-p instance)
+ (format stream "at 0x~X" (pointer-address (foreign-location instance)))
+ (write-string "at \"unbound\"" stream))))
+
+
+(defmethod initialize-instance :around ((instance proxy) &rest initargs &key &allow-other-keys)
+ (setf
+ (foreign-location instance)
+ (apply #'allocate-foreign instance initargs))
+ (prog1
+ (call-next-method)
+ (cache-instance instance)
+ (finalize instance (instance-finalizer instance))))
+
+(defmethod instance-finalizer :around ((instance proxy))
+ (let ((finalizer (call-next-method)))
+ (let ((location (foreign-location instance)))
+ #+(or cmu sbcl)
+ #'(lambda ()
+ (remove-cached-instance location)
+ (funcall finalizer))
+ #+clisp
+ #'(lambda (instance)
+ (declare (ignore instance))
+ (remove-cached-instance location)
+ (funcall finalizer)))))
+
+(defmethod instance-finalizer ((instance proxy))
+ (let ((location (foreign-location instance))
+ (unref (unreference-function (class-of instance))))
+ #'(lambda ()
+ (funcall unref location))))
+
+;; FINALIZE-P should always be given the same value as the keyword
+;; argument :FINALZIE given to MAKE-PROXY-INSTANCE or non NIL if the
+;; proxy was created with MAKE-INSTANCE
+(defmethod invalidate-instance ((instance proxy) &optional finalize-p)
+ (remove-cached-instance (foreign-location instance))
+ #+(or sbcl cmu)
+ (progn
+ (when finalize-p
+ (funcall (instance-finalizer instance)))
+ (slot-makunbound instance 'location)
+ (cancel-finalization instance))
+ ;; We can't cached invalidated instances in CLISP beacuse it is
+ ;; not possible to cancel finalization
+ #-clisp(cache-invalidated-instance instance))
+
+
+;;;; Metaclass used for subclasses of proxy
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defclass proxy-class (virtual-slots-class)
+ ((size :accessor foreign-size)
+ (packed :reader foreign-slots-packed-p)
+ (ref :reader reference-function)
+ (unref :reader unreference-function)))
+
+ (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
+ ((offset :reader slot-definition-offset :initarg :offset))
+ (:default-initargs :allocation :alien))
+
+ (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
+ ((offset :reader slot-definition-offset :initarg :offset)))
+
+ (defclass direct-virtual-alien-slot-definition (direct-virtual-slot-definition)
+ ())
+
+ (defclass effective-virtual-alien-slot-definition (effective-virtual-slot-definition)
+ ())
+
+ (defgeneric foreign-size-p (class))
+ (defgeneric most-specific-proxy-superclass (class))
+ (defgeneric direct-proxy-superclass (class))
+
+ (defmethod foreign-size-p ((class proxy-class))
+ (slot-boundp class 'size))
+
+ (defmethod most-specific-proxy-superclass ((class proxy-class))
+ (find-if
+ #'(lambda (class)
+ (subtypep (class-name class) 'proxy))
+ (cdr (compute-class-precedence-list class))))
+
+ (defmethod direct-proxy-superclass ((class proxy-class))
+ (find-if
+ #'(lambda (class)
+ (subtypep (class-name class) 'proxy))
+ (class-direct-superclasses class)))
+
+ (defmethod shared-initialize ((class proxy-class) names
+ &key size packed ref unref)
+ (declare (ignore names))
+ (cond
+ (size (setf (slot-value class 'size) (first size)))
+ ((slot-boundp class 'size) (slot-makunbound class 'size)))
+ (setf (slot-value class 'packed) (first packed))
+ (when ref
+ (setf (slot-value class 'ref) (first ref)))
+ (when unref
+ (setf (slot-value class 'unref) (first unref)))
+ (call-next-method))
+
+ (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
+ (case (getf initargs :allocation)
+ (:alien (find-class 'direct-alien-slot-definition))
+ (:virtual (find-class 'direct-virtual-alien-slot-definition))
+ (t (call-next-method))))
+
+ (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs)
+ (case (getf initargs :allocation)
+ (:alien (find-class 'effective-alien-slot-definition))
+ (:virtual (find-class 'effective-virtual-alien-slot-definition))
+ (t (call-next-method))))
+
+
+ (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
+ (if (eq (slot-definition-allocation (first direct-slotds)) :alien)
+ (nconc
+ (list :offset (most-specific-slot-value direct-slotds 'offset))
+ (call-next-method))
+ (call-next-method)))
+
+
+ (defmethod compute-slot-reader-function ((slotd effective-alien-slot-definition))
+ (let* ((type (slot-definition-type slotd))
+ (offset (slot-definition-offset slotd))
+ (reader (reader-function type)))
+ #'(lambda (object)
+ (funcall reader (foreign-location object) offset))))
+
+ (defmethod compute-slot-writer-function ((slotd effective-alien-slot-definition))
+ (let* ((type (slot-definition-type slotd))
+ (offset (slot-definition-offset slotd))
+ (writer (writer-function type))
+ (destroy (destroy-function type)))
+ #'(lambda (value object)
+ (let ((location (foreign-location object)))
+ (funcall destroy location offset) ; destroy old value
+ (funcall writer value location offset))
+ value)))
+
+ (defmethod compute-slot-reader-function ((slotd effective-virtual-alien-slot-definition))
+ (if (and (slot-boundp slotd 'getter) (stringp (slot-definition-getter slotd)))
+ (let ((getter (slot-definition-getter slotd))
+ (type (slot-definition-type slotd))
+ (reader nil))
+ #'(lambda (object)
+ (unless reader
+ (setq reader (mkbinding getter type 'pointer)))
+ (funcall reader (foreign-location object))))
+ (call-next-method)))
+
+ (defmethod compute-slot-writer-function ((slotd effective-virtual-alien-slot-definition))
+ (if (and (slot-boundp slotd 'setter) (stringp (slot-definition-setter slotd)))
+ (let ((setter (slot-definition-setter slotd))
+ (type (slot-definition-type slotd))
+ (writer nil))
+ #'(lambda (value object)
+ (unless writer
+ (setq writer (mkbinding setter nil 'pointer type)))
+ (funcall writer (foreign-location object) value)))
+ (call-next-method)))
+
+ (defconstant +struct-alignmen+ (size-of 'pointer))
+
+ (defun align-offset (size &optional packed-p)
+ (if (or packed-p (zerop (mod size +struct-alignmen+)))
+ size
+ (+ size (- +struct-alignmen+ (mod size +struct-alignmen+)))))
+
+ (defmethod compute-slots ((class proxy-class))
+ (let ((alien-slots (remove-if-not
+ #'(lambda (allocation) (eq allocation :alien))
+ (class-direct-slots class)
+ :key #'slot-definition-allocation)))
+ (when alien-slots
+ (loop
+ with packed-p = (foreign-slots-packed-p class)
+ as offset = (align-offset
+ (foreign-size (most-specific-proxy-superclass class))
+ packed-p)
+ then (align-offset
+ (+
+ (slot-definition-offset slotd)
+ (size-of (slot-definition-type slotd)))
+ packed-p)
+ for slotd in alien-slots
+ unless (slot-boundp slotd 'offset)
+ do (setf (slot-value slotd 'offset) offset))))
+ (call-next-method))
+
+ (defmethod validate-superclass ((class proxy-class) (super standard-class))
+ (subtypep (class-name super) 'proxy))
+
+ (defmethod foreign-size ((class-name symbol))
+ (foreign-size (find-class class-name))))
+
+(defmethod foreign-size ((object proxy))
+ (foreign-size (class-of object)))
+
+(define-type-method alien-type ((type proxy))
+ (declare (ignore type))
+ (alien-type 'pointer))
+
+(define-type-method size-of ((type proxy) &key inlined)
+ (assert-not-inlined type inlined)
+ (size-of 'pointer))
+
+(define-type-method from-alien-form ((type proxy) form &key (ref :free))
+ (let ((class (type-expand type)))
+ (ecase ref
+ (:free `(ensure-proxy-instance ',class ,form :reference nil))
+ (:copy `(ensure-proxy-instance ',class ,form))
+ ((:static :temp) `(ensure-proxy-instance ',class ,form
+ :reference nil :finalize nil)))))
+
+(define-type-method from-alien-function ((type proxy) &key (ref :free))
+ (let ((class (type-expand type)))
+ (ecase ref
+ (:free
+ #'(lambda (location)
+ (ensure-proxy-instance class location :reference nil)))
+ (:copy
+ #'(lambda (location)
+ (ensure-proxy-instance class location)))
+ ((:static :temp)
+ #'(lambda (location)
+ (ensure-proxy-instance class location :reference nil :finalize nil))))))
+
+(define-type-method to-alien-form ((type proxy) instance &optional copy-p)
+ (if copy-p
+ (let* ((class (type-expand type))
+ (ref (reference-function class)))
+ (if (symbolp ref)
+ `(,ref (foreign-location ,instance))
+ `(funcall (reference-function ',class)
+ (foreign-location ,instance))))
+ `(foreign-location ,instance)))
+
+(define-type-method to-alien-function ((type proxy) &optional copy-p)
+ (if copy-p
+ (let ((ref (reference-function (type-expand type))))
+ #'(lambda (instance)
+ (funcall ref (foreign-location instance))))
+ #'foreign-location))
+
+(define-type-method size-of ((type proxy) &key inlined)
+ (assert-not-inlined type inlined)
+ (size-of 'pointer))
+
+(define-type-method writer-function ((type proxy) &key temp inlined)
+ (assert-not-inlined type inlined)
+ (if temp
+ #'(lambda (instance location &optional (offset 0))
+ (assert (null-pointer-p (ref-pointer location offset)))
+ (setf (ref-pointer location offset) (foreign-location instance)))
+ (let ((ref (reference-function (type-expand type))))
+ #'(lambda (instance location &optional (offset 0))
+ (assert (null-pointer-p (ref-pointer location offset)))
+ (setf
+ (ref-pointer location offset)
+ (funcall ref (foreign-location instance)))))))
+
+(define-type-method reader-function ((type proxy) &key (ref :read) inlined)
+ (assert-not-inlined type inlined)
+ (let ((class (type-expand type)))
+ (ecase ref
+ (:read
+ #'(lambda (location &optional (offset 0))
+ (let ((instance (ref-pointer location offset)))
+ (unless (null-pointer-p instance)
+ (ensure-proxy-instance class instance)))))
+ (:peek
+ #'(lambda (location &optional (offset 0))
+ (let ((instance (ref-pointer location offset)))
+ (unless (null-pointer-p instance)
+ (ensure-proxy-instance class instance
+ :reference nil :finalize nil)))))
+ (:get
+ #'(lambda (location &optional (offset 0))
+ (let ((instance (ref-pointer location offset)))
+ (unless (null-pointer-p instance)
+ (prog1
+ (ensure-proxy-instance class instance :reference nil)
+ (setf (ref-pointer location offset) (make-pointer 0))))))))))
+
+(define-type-method destroy-function ((type proxy) &key temp inlined)
+ (assert-not-inlined type inlined)
+ (if temp
+ #'(lambda (location &optional (offset 0))
+ (setf (ref-pointer location offset) (make-pointer 0)))
+ (let ((unref (unreference-function (type-expand type))))
+ #'(lambda (location &optional (offset 0))
+ (unless (null-pointer-p (ref-pointer location offset))
+ (funcall unref (ref-pointer location offset))
+ (setf (ref-pointer location offset) (make-pointer 0)))))))
+
+(define-type-method copy-function ((type proxy) &key inlined)
+ (assert-not-inlined type inlined)
+ (let ((ref (reference-function (type-expand type))))
+ #'(lambda (from to &optional (offset 0))
+ (let ((instance (ref-pointer from offset)))
+ (unless (null-pointer-p instance)
+ (funcall ref instance))
+ (setf (ref-pointer to offset) instance)))))
+
+(define-type-method unbound-value ((type proxy))
+ (declare (ignore type))
+ nil)
+
+(defun ensure-proxy-instance (class location &rest initargs)
+ "Returns a proxy object representing the foreign object at the give
+location. If an existing proxy object is not found,
+MAKE-PROXY-INSTANCE is called to create a new one. A second return
+value indicates whether a new proxy was created or not."
+ (unless (null-pointer-p location)
+ (or
+ #-debug-ref-counting(find-cached-instance location)
+ #+debug-ref-counting
+ (let ((instance (find-cached-instance location)))
+ (when instance
+ (format t "Object found in cache: ~A~%" instance)
+ instance))
+ (values
+ (apply #'make-proxy-instance class location initargs)
+ t))))
+
+(defgeneric make-proxy-instance (class location &key reference finalize)
+ (:documentation "Creates a new proxy object representing the foreign
+object at the give location."))
+
+(defmethod make-proxy-instance ((class symbol) location &rest initargs)
+ (apply #'make-proxy-instance (find-class class) location initargs))
+
+(defmethod make-proxy-instance ((class proxy-class) location
+ &key (reference t) (finalize t))
+ (let ((instance
+ (or
+ (find-invalidated-instance class)
+ (allocate-instance class))))
+ (setf (foreign-location instance)
+ (if reference
+ (funcall (reference-function class) location)
+ location))
+ (finalize instance
+ (if finalize
+ (instance-finalizer instance)
+ ;; We still need to remove the instance from the cache even if we
+ ;; don't do normal finalization
+ (let ((location (foreign-location instance)))
+ #+(or cmu sbcl)
+ #'(lambda ()
+ (remove-cached-instance location))
+ #+clisp
+ #'(lambda (instance)
+ (declare (ignore instance))
+ (remove-cached-instance location)))))
+ (cache-instance instance)
+ instance))
+
+
+;;;; Superclasses for wrapping of C structures
+
+(defclass struct (proxy)
+ ()
+ (:metaclass proxy-class)
+ (:size 0))
+
+(defmethod allocate-foreign ((struct struct) &rest initargs)
+ (declare (ignore initargs))
+ (let ((size (foreign-size (class-of struct))))
+ (if (zerop size)
+ (error "~A has zero size" (class-of struct))
+ (allocate-memory size))))
+
+
+;;;; Metaclasses used for subclasses of struct
+
+(defclass struct-class (proxy-class)
+ ())
+
+(defmethod shared-initialize ((class struct-class) names &rest initargs)
+ (declare (ignore names initargs))
+ (call-next-method)
+ (let ((offsets nil) (copy-functions nil) (destroy-functions nil))
+ (flet ((initialize-functions ()
+ (loop
+ for slotd in (class-slots class)
+ as type = (slot-definition-type slotd)
+ when (eq (slot-definition-allocation slotd) :alien)
+ do (push (slot-definition-offset slotd) offsets)
+ (push (copy-function type) copy-functions)
+ (push (destroy-function type) destroy-functions))))
+ (unless (slot-boundp class 'ref)
+ (setf
+ (slot-value class 'ref)
+ #'(lambda (from &optional (to (allocate-memory (foreign-size class))))
+ (assert (not (null-pointer-p from)))
+ (unless offsets
+ (initialize-functions))
+ (loop
+ for offset in offsets
+ for copy in copy-functions
+ do (funcall copy from to offset))
+ to)))
+ (unless (slot-boundp class 'unref)
+ (setf (slot-value class 'unref)
+ #'(lambda (location &optional inlined-p)
+ (assert (not (null-pointer-p location)))
+ (unless offsets
+ (initialize-functions))
+ (loop
+ for offset in offsets
+ for destroy in destroy-functions
+ do (funcall destroy location offset))
+ (unless inlined-p
+ (deallocate-memory location))))))))
+
+
+(defmethod direct-slot-definition-class ((class struct-class) &rest initargs)
+ (if (not (getf initargs :allocation))
+ (find-class 'direct-alien-slot-definition)
+ (call-next-method)))
+
+
+(defmethod compute-slots :around ((class struct-class))
+ (let ((slots (call-next-method)))
+ (when (and
+ #?-(or (sbcl>= 0 9 8) (featurep :clisp))(class-finalized-p class)
+ (not (slot-boundp class 'size)))
+ (let ((size (or
+ (loop
+ for slotd in slots
+ when (eq (slot-definition-allocation slotd) :alien)
+ maximize (+
+ (slot-definition-offset slotd)
+ (size-of (slot-definition-type slotd))))
+ 0)))
+ (setf (slot-value class 'size) (+ size (mod size +struct-alignmen+)))))
+ slots))
+
+(define-type-method callback-wrapper ((type struct) var arg form)
+ (let ((class (type-expand type)))
+ `(let ((,var (ensure-proxy-instance ',class ,arg :finalize nil)))
+ (unwind-protect
+ ,form
+ (invalidate-instance ,var)))))
+
+(define-type-method size-of ((type struct) &key inlined)
+ (if inlined
+ (foreign-size type)
+ (size-of 'pointer)))
+
+(define-type-method writer-function ((type struct) &key temp inlined)
+ (if inlined
+ (if temp
+ (let ((size (size-of type :inlined t)))
+ #'(lambda (instance location &optional (offset 0))
+ (copy-memory
+ (foreign-location instance) size
+ (pointer+ location offset))))
+ (let ((ref (reference-function (type-expand type))))
+ #'(lambda (instance location &optional (offset 0))
+ (funcall ref
+ (foreign-location instance)
+ (pointer+ location offset)))))
+ (call-next-method)))
+
+(define-type-method reader-function ((type struct) &key (ref :read) inlined)
+ (if inlined
+ (let ((class (type-expand type))
+ (size (size-of type :inlined t)))
+ (ecase ref
+ (:read
+ #'(lambda (location &optional (offset 0))
+ (ensure-proxy-instance class (pointer+ location offset))))
+ (:peek
+ #'(lambda (location &optional (offset 0))
+ (ensure-proxy-instance class (pointer+ location offset)
+ :reference nil :finalize nil)))
+ (:get
+ #'(lambda (location &optional (offset 0))
+ (prog1
+ (ensure-proxy-instance class
+ (copy-memory (pointer+ location offset) size)
+ :reference nil)
+ (clear-memory (pointer+ location offset) size))))))
+ (call-next-method)))
+
+(define-type-method destroy-function ((type struct) &key temp inlined)
+ (if inlined
+ (let ((size (size-of type :inlined t)))
+ (if temp
+ #'(lambda (location &optional (offset 0))
+ (clear-memory (pointer+ location offset) size))
+ (let ((unref (unreference-function (type-expand type))))
+ #'(lambda (location &optional (offset 0))
+ (funcall unref (pointer+ location offset) t)))))
+ (call-next-method)))
+
+(define-type-method copy-function ((type struct) &key inlined)
+ (if inlined
+ (let ((ref (reference-function (type-expand type))))
+ #'(lambda (from to &optional (offset 0))
+ (funcall ref (pointer+ from offset) (pointer+ to offset))))
+ (call-next-method)))
--- /dev/null
+;; 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.1 2006-04-25 20:49:16 espen Exp $
+
+(in-package "GFFI")
+
+;;;; Superclass for all metaclasses implementing some sort of virtual slots
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (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))))
+
+(defgeneric compute-slot-reader-function (slotd))
+(defgeneric compute-slot-boundp-function (slotd))
+(defgeneric compute-slot-writer-function (slotd))
+(defgeneric compute-slot-makunbound-function (slotd))
+
+
+#+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))))
+
+
+(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 ((slotd effective-virtual-slot-definition))
+ (if (slot-boundp slotd 'getter)
+ (slot-value slotd 'getter)
+ #'(lambda (object)
+ (error 'unreadable-slot :name (slot-definition-name slotd) :instance object))))
+
+(defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definition))
+ (cond
+ ;; An explicit boundp function has been supplied
+ ((slot-boundp slotd 'boundp) (slot-value slotd 'boundp))
+
+ ;; An unbound value has been supplied
+ ((slot-boundp slotd 'unbound)
+ (let ((reader-function (slot-value slotd 'reader-function))
+ (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 (slot-value slotd 'reader-function))
+ (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))))
+
+(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 ((slotd effective-virtual-slot-definition))
+ (if (slot-boundp slotd 'setter)
+ (slot-value slotd 'setter)
+ #'(lambda (value object)
+ (declare (ignore value))
+ (error 'unwritable-slot :name (slot-definition-name slotd) :instance object))))
+
+(defmethod compute-slot-makunbound-function ((slotd effective-virtual-slot-definition))
+ (cond
+ ((slot-boundp slotd 'makunbound) (slot-value slotd 'makunbound))
+ ((slot-boundp slotd 'unbound)
+ #'(lambda (object)
+ (funcall (slot-value slotd 'writer-function) (slot-value slotd 'unbound) object)))
+ (t
+ #'(lambda (object)
+ (error 'unwritable-slot :name (slot-definition-name slotd) :instance object)))))
+
+
+#-clisp
+(defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
+ (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))))
+
+
+(defmethod slot-value-using-class
+ ((class virtual-slots-class) (object standard-object)
+ (slotd effective-virtual-slot-definition))
+ ;; This isn't optimal when we have an unbound value, as the reader
+ ;; function gets invoke twice
+ (if (funcall (slot-value slotd 'boundp-function) object)
+ (funcall (slot-value slotd 'reader-function) object)
+ (slot-unbound class object (slot-definition-name slotd))))
+
+(defmethod slot-boundp-using-class
+ ((class virtual-slots-class) (object standard-object)
+ (slotd effective-virtual-slot-definition))
+ (handler-case
+ (funcall (slot-value slotd 'boundp-function) object)
+ (unreadable-slot (condition)
+ (declare (ignore condition))
+ nil)))
+
+(defmethod (setf slot-value-using-class)
+ (value (class virtual-slots-class) (object standard-object)
+ (slotd effective-virtual-slot-definition))
+ (funcall (slot-value slotd 'writer-function) value object))
+
+(defmethod slot-makunbound-using-class
+ ((class virtual-slots-class) (object standard-object)
+ (slotd effective-virtual-slot-definition))
+ (funcall (slot-value slotd 'makunbound-function) object))
+
+
+;; In CLISP a class may not have been finalized when update-slots are
+;; called. So to avoid the possibility of finalize-instance beeing
+;; called recursivly we have to delay the initialization of slot
+;; functions until after an instance has been created. We therefor do
+;; it in around methods for the generic functions used to access
+;; slots.
+#+clisp
+(defmethod slot-value-using-class :around ((class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition))
+ (unless (slot-boundp slotd 'reader-function)
+ (setf
+ (slot-value slotd 'reader-function) (compute-slot-reader-function slotd)
+ (slot-value slotd 'boundp-function) (compute-slot-boundp-function slotd)))
+ (call-next-method))
+
+#+clisp
+(defmethod slot-boundp-using-class :around ((class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition))
+ (unless (slot-boundp slotd 'boundp-function)
+ (setf
+ (slot-value slotd 'reader-function) (compute-slot-reader-function slotd)
+ (slot-value slotd 'boundp-function) (compute-slot-boundp-function slotd)))
+ (call-next-method))
+
+#+clisp
+(defmethod (setf slot-value-using-class) :around (value (class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition))
+ (declare (ignore value))
+ (unless (slot-boundp slotd 'writer-function)
+ (setf
+ (slot-value slotd 'writer-function) (compute-slot-writer-function slotd)))
+ (call-next-method))
+
+#+clisp
+(defmethod slot-makunbound-using-class :around ((class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition))
+ (unless (slot-boundp slotd 'makunbound-function)
+ (setf
+ (slot-value slotd 'makunbound-function)
+ (compute-slot-makunbound-function slotd)))
+ (call-next-method))
+
+(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)
+
+
+(defclass virtual-slots-object (standard-object)
+ ())
+
+
+;;; 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 which 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)))
~mdw / clg / commitdiff