;; 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 $
+;; $Id: proxy.lisp,v 1.10 2007-12-11 14:26:11 espen Exp $
(in-package "GFFI")
;;;; Proxy for alien instances
-#+clisp
-(defvar *foreign-instance-locations* (make-hash-table :weak :key))
+#?(or (sbcl>= 0 9 17) (featurep :clisp))
+(defvar *foreign-instance-locations*
+ (make-hash-table #+clisp :weak #+sbcl :weakness :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))
+ (#?-(or (sbcl>= 0 9 17) (featurep :clisp))(%location :special t :type pointer))
(:metaclass virtual-slots-class)))
(defgeneric instance-finalizer (instance))
(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*))
+#?-(or (sbcl>= 0 9 17) (featurep :clisp))
+(progn
+ (defun foreign-location (instance)
+ (slot-value instance '%location))
+
+ (defun (setf foreign-location) (location instance)
+ (setf (slot-value instance '%location) location))
+
+ (defun proxy-valid-p (instance)
+ (slot-boundp instance '%location)))
+
+#?(or (sbcl>= 0 9 17) (featurep :clisp))
+(progn
+ (defun foreign-location (instance)
+ (gethash instance *foreign-instance-locations*))
+
+ (defun (setf foreign-location) (location instance)
+ (setf (gethash instance *foreign-instance-locations*) location))
-(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)
+ (and (gethash instance *foreign-instance-locations*) t)))
-(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)))
#'(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
+;; FINALIZE-P should always be the same 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)
+ #+clisp(declare (ignore finalize-p))
(remove-cached-instance (foreign-location instance))
#+(or sbcl cmu)
(progn
(when finalize-p
(funcall (instance-finalizer instance)))
- (slot-makunbound instance 'location)
+ #?-(sbcl>= 0 9 17)(slot-makunbound instance '%location)
+ #?(sbcl>= 0 9 17)(remhash instance *foreign-instance-locations*)
(cancel-finalization instance))
- ;; We can't cached invalidated instances in CLISP beacuse it is
+ ;; We can't cache invalidated instances in CLISP beacuse it is
;; not possible to cancel finalization
#-clisp(cache-invalidated-instance instance))
(call-next-method))
(call-next-method)))
+ (defmethod slot-readable-p ((slotd effective-alien-slot-definition))
+ (declare (ignore slotd))
+ t)
- (defmethod compute-slot-reader-function ((slotd effective-alien-slot-definition))
+ (defmethod compute-slot-reader-function ((slotd effective-alien-slot-definition) &optional signal-unbound-p)
+ (declare (ignore signal-unbound-p))
(let* ((type (slot-definition-type slotd))
(offset (slot-definition-offset slotd))
(reader (reader-function type)))
#'(lambda (object)
(funcall reader (foreign-location object) offset))))
+ (defmethod slot-writable-p ((slotd effective-alien-slot-definition))
+ (declare (ignore slotd))
+ t)
+
(defmethod compute-slot-writer-function ((slotd effective-alien-slot-definition))
(let* ((type (slot-definition-type slotd))
(offset (slot-definition-offset slotd))
(funcall writer value location offset))
value)))
- (defmethod compute-slot-reader-function ((slotd effective-virtual-alien-slot-definition))
+ (defmethod compute-slot-reader-function ((slotd effective-virtual-alien-slot-definition) &optional signal-unbound-p)
+ (declare (ignore signal-unbound-p))
(if (and (slot-boundp slotd 'getter) (stringp (slot-definition-getter slotd)))
(let ((getter (slot-definition-getter slotd))
(type (slot-definition-type slotd))
#'(lambda (value object)
(unless writer
(setq writer (mkbinding setter nil 'pointer type)))
+ ;; First argument in foreign setters is the object and second
+ ;; is value
(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+)))))
+ (defun adjust-offset (offset type &optional packed-p)
+ (let ((alignment (type-alignment type)))
+ (if (or packed-p (zerop (mod offset alignment)))
+ offset
+ (+ offset (- alignment (mod offset alignment))))))
(defmethod compute-slots ((class proxy-class))
(let ((alien-slots (remove-if-not
(when alien-slots
(loop
with packed-p = (foreign-slots-packed-p class)
- as offset = (align-offset
+ for slotd in alien-slots
+ as offset = (adjust-offset
(foreign-size (most-specific-proxy-superclass class))
+ (slot-definition-type slotd)
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))))
+ then (adjust-offset offset (slot-definition-type slotd) packed-p)
+ do (if (slot-boundp slotd 'offset)
+ (setf offset (slot-value slotd 'offset))
+ (setf (slot-value slotd 'offset) offset))
+ (incf offset (size-of (slot-definition-type slotd))))))
(call-next-method))
(defmethod validate-superclass ((class proxy-class) (super standard-class))
(assert-not-inlined type inlined)
(size-of 'pointer))
+(define-type-method type-alignment ((type proxy) &key inlined)
+ (assert-not-inlined type inlined)
+ (type-alignment 'pointer))
+
(define-type-method from-alien-form ((type proxy) form &key (ref :free))
(let ((class (type-expand type)))
(ecase ref
(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
(cache-instance instance)
instance))
+;;;; Superclass for ref-counted objects
+
+(defclass ref-counted-object (proxy)
+ ()
+ (:metaclass proxy-class))
+
+(define-type-method from-alien-form ((type ref-counted-object) form
+ &key (ref :copy))
+ (call-next-method type form :ref ref))
+
+(define-type-method from-alien-function ((type ref-counted-object)
+ &key (ref :copy))
+ (call-next-method type :ref ref))
+
;;;; Superclasses for wrapping of C structures
(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+)))))
+ (setf (slot-value class '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)))
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)))
+ `(let ((,var (ensure-proxy-instance ',class ,arg :reference nil :finalize nil)))
(unwind-protect
,form
(invalidate-instance ,var)))))
(foreign-size type)
(size-of 'pointer)))
+(define-type-method type-alignment ((type struct) &key inlined)
+ (if inlined
+ (let ((slot1 (find-if
+ #'(lambda (slotd)
+ (eq (slot-definition-allocation slotd) :alien))
+ (class-slots (find-class type)))))
+ (type-alignment (slot-definition-type slot1)))
+ (type-alignment 'pointer)))
+
(define-type-method writer-function ((type struct) &key temp inlined)
(if inlined
(if temp
~mdw / clg / blobdiff