+(define-type-method to-alien-form ((type proxy) instance)
+ (declare (ignore type))
+ `(foreign-location ,instance))
+
+(define-type-method to-alien-function ((type proxy))
+ (declare (ignore type))
+ #'foreign-location)
+
+(define-type-method copy-from-alien-form ((type proxy) location)
+ (let ((class (type-expand type)))
+ `(ensure-proxy-instance ',class (reference-foreign ',class ,location))))
+
+(define-type-method copy-from-alien-function ((type proxy))
+ (let ((class (type-expand type)))
+ #'(lambda (location)
+ (ensure-proxy-instance class (reference-foreign class location)))))
+
+(define-type-method copy-to-alien-form ((type proxy) instance)
+ (let ((class (type-expand type)))
+ `(reference-foreign ',class (foreign-location ,instance))))
+
+(define-type-method copy-to-alien-function ((type proxy))
+ (let ((class (type-expand type)))
+ #'(lambda (instance)
+ (reference-foreign class (foreign-location instance)))))
+
+(define-type-method writer-function ((type proxy))
+ (let ((class (type-expand type)))
+ #'(lambda (instance location &optional (offset 0))
+ (assert (null-pointer-p (sap-ref-sap location offset)))
+ (setf
+ (sap-ref-sap location offset)
+ (reference-foreign class (foreign-location instance))))))
+
+(define-type-method reader-function ((type proxy))
+ (let ((class (type-expand type)))
+ #'(lambda (location &optional (offset 0) weak-p)
+ (declare (ignore weak-p))
+ (let ((instance (sap-ref-sap location offset)))
+ (unless (null-pointer-p instance)
+ (ensure-proxy-instance class (reference-foreign class instance)))))))
+
+(define-type-method destroy-function ((type proxy))
+ (let ((class (type-expand type)))
+ #'(lambda (location &optional (offset 0))
+ (unreference-foreign class (sap-ref-sap location offset)))))
+
+(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 object is not found in the cache
+MAKE-PROXY-INSTANCE is called to create one."
+ (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))
+ (let ((instance (apply #'make-proxy-instance class location initargs)))
+ (cache-instance instance)
+ instance))))
+
+(defgeneric make-proxy-instance (class location &key weak)
+ (:documentation "Creates a new proxy object representing the foreign
+object at the give location. If WEAK is non NIL the foreign memory
+will not be released when the proxy is garbage collected."))
+
+(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 weak)
+ (let ((instance
+ (or
+ (find-invalidated-instance class)
+ (allocate-instance class))))
+ (setf (foreign-location instance) location)
+ (unless weak
+ (finalize instance (instance-finalizer instance)))
+ instance))