chiark - git - mdw - clg/blob - gffi/proxy.lisp

   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
  23 ;; $Id: proxy.lisp,v 1.4 2006-08-16 12:09:03 espen Exp $
  24
  25 (in-package "GFFI")
  26
  27
  28 ;;;; Proxy cache
  29
  30 (defvar *instance-cache* (make-hash-table :test #'eql))
  31
  32 (defun cache-instance (instance &optional (weak-ref t))
  33   (setf
  34    (gethash (pointer-address (foreign-location instance)) *instance-cache*)
  35    (if weak-ref
  36        (make-weak-pointer instance)
  37      instance)))
  38
  39 (defun find-cached-instance (location)
  40   (let ((ref (gethash (pointer-address location) *instance-cache*)))
  41     (when ref
  42       (if (weak-pointer-p ref)
  43           (weak-pointer-value ref)
  44         ref))))
  45
  46 (defun instance-cached-p (location)
  47   (gethash (pointer-address location) *instance-cache*))
  48
  49 (defun remove-cached-instance (location)
  50   (remhash (pointer-address location) *instance-cache*))
  51
  52 ;; For debuging
  53 (defun list-cached-instances ()
  54   (let ((instances ()))
  55     (maphash #'(lambda (location ref)
  56                  (declare (ignore location))
  57                  (push ref instances))
  58              *instance-cache*)
  59     instances))
  60
  61 ;; Instances that gets invalidated tend to be short lived, but created
  62 ;; in large numbers. So we're keeping them in a hash table to be able
  63 ;; to reuse them (and thus reduce consing)
  64 (defvar *invalidated-instance-cache* (make-hash-table :test #'eql))
  65
  66 (defun cache-invalidated-instance (instance)
  67   (push instance
  68    (gethash (class-of instance) *invalidated-instance-cache*)))
  69
  70 (defun find-invalidated-instance (class)
  71   (when (gethash class *invalidated-instance-cache*)
  72     (pop (gethash class *invalidated-instance-cache*))))
  73
  74 (defun list-invalidated-instances ()
  75   (let ((instances ()))
  76     (maphash #'(lambda (location ref)
  77                  (declare (ignore location))
  78                  (push ref instances))
  79              *invalidated-instance-cache*)
  80     instances))
  81
  82
  83
  84 ;;;; Proxy for alien instances
  85
  86 #+clisp
  87 (defvar *foreign-instance-locations* (make-hash-table :weak :key))
  88
  89 ;; TODO: add a ref-counted-proxy subclass
  90 (eval-when (:compile-toplevel :load-toplevel :execute)
  91   (defclass proxy (virtual-slots-object)
  92     (#-clisp(location :special t :type pointer))
  93     (:metaclass virtual-slots-class)))
  94
  95 (defgeneric instance-finalizer (instance))
  96 (defgeneric reference-function (class))
  97 (defgeneric unreference-function (class))
  98 (defgeneric invalidate-instance (instance &optional finalize-p))
  99 (defgeneric allocate-foreign (object &key &allow-other-keys))
 100
 101 (defun foreign-location (instance)
 102   #-clisp(slot-value instance 'location)
 103   #+clisp(gethash instance *foreign-instance-locations*))
 104
 105 (defun (setf foreign-location) (location instance)
 106   #-clisp(setf (slot-value instance 'location) location)
 107   #+clisp(setf (gethash instance *foreign-instance-locations*) location))
 108
 109 (defun proxy-valid-p (instance)
 110   #-clisp(slot-boundp instance 'location)
 111   #+clisp(and (gethash instance *foreign-instance-locations*) t))
 112
 113 (defmethod reference-function ((name symbol))
 114   (reference-function (find-class name)))
 115
 116 (defmethod unreference-function ((name symbol))
 117   (unreference-function (find-class name)))
 118
 119 (defmethod print-object ((instance proxy) stream)
 120   (print-unreadable-object (instance stream :type t :identity nil)
 121     (if (proxy-valid-p instance)
 122         (format stream "at 0x~X" (pointer-address (foreign-location instance)))
 123       (write-string "at \"unbound\"" stream))))
 124
 125
 126 (defmethod initialize-instance :around ((instance proxy) &rest initargs &key &allow-other-keys)
 127   (setf
 128    (foreign-location instance)
 129    (apply #'allocate-foreign instance initargs))
 130   (prog1
 131       (call-next-method)
 132     (cache-instance instance)
 133     (finalize instance (instance-finalizer instance))))
 134
 135 (defmethod instance-finalizer :around ((instance proxy))
 136   (let ((finalizer (call-next-method)))
 137     (let ((location (foreign-location instance)))
 138       #+(or cmu sbcl)
 139       #'(lambda ()
 140           (remove-cached-instance location)
 141           (funcall finalizer))
 142       #+clisp
 143       #'(lambda (instance)
 144           (declare (ignore instance))
 145           (remove-cached-instance location)
 146           (funcall finalizer)))))
 147
 148 (defmethod instance-finalizer ((instance proxy))
 149   (let ((location (foreign-location instance))
 150         (unref (unreference-function (class-of instance))))
 151     #'(lambda ()
 152         (funcall unref location))))
 153
 154 ;; FINALIZE-P should always be given the same value as the keyword
 155 ;; argument :FINALZIE given to MAKE-PROXY-INSTANCE or non NIL if the
 156 ;; proxy was created with MAKE-INSTANCE
 157 (defmethod invalidate-instance ((instance proxy) &optional finalize-p)
 158   (remove-cached-instance (foreign-location instance))
 159   #+(or sbcl cmu)
 160   (progn
 161     (when finalize-p
 162       (funcall (instance-finalizer instance)))
 163     (slot-makunbound instance 'location)
 164     (cancel-finalization instance))
 165   ;; We can't cache invalidated instances in CLISP beacuse it is
 166   ;; not possible to cancel finalization
 167   #-clisp(cache-invalidated-instance instance))
 168
 169
 170 ;;;; Metaclass used for subclasses of proxy
 171
 172 (eval-when (:compile-toplevel :load-toplevel :execute)
 173   (defclass proxy-class (virtual-slots-class)
 174     ((size :accessor foreign-size)
 175      (packed :reader foreign-slots-packed-p)
 176      (ref :reader reference-function)
 177      (unref :reader unreference-function)))
 178
 179   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
 180     ((offset :reader slot-definition-offset :initarg :offset))
 181     (:default-initargs :allocation :alien))
 182
 183   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
 184     ((offset :reader slot-definition-offset :initarg :offset)))
 185
 186   (defclass direct-virtual-alien-slot-definition (direct-virtual-slot-definition)
 187     ())
 188
 189   (defclass effective-virtual-alien-slot-definition (effective-virtual-slot-definition)
 190     ())
 191
 192   (defgeneric foreign-size-p (class))
 193   (defgeneric most-specific-proxy-superclass (class))
 194   (defgeneric direct-proxy-superclass (class))
 195
 196   (defmethod foreign-size-p ((class proxy-class))
 197     (slot-boundp class 'size))
 198
 199   (defmethod most-specific-proxy-superclass ((class proxy-class))
 200     (find-if
 201      #'(lambda (class)
 202          (subtypep (class-name class) 'proxy))
 203      (cdr (compute-class-precedence-list class))))
 204
 205   (defmethod direct-proxy-superclass ((class proxy-class))
 206     (find-if
 207      #'(lambda (class)
 208          (subtypep (class-name class) 'proxy))
 209      (class-direct-superclasses class)))
 210
 211   (defmethod shared-initialize ((class proxy-class) names
 212                                 &key size packed ref unref)
 213     (declare (ignore names))
 214     (cond
 215      (size (setf (slot-value class 'size) (first size)))
 216      ((slot-boundp class 'size) (slot-makunbound class 'size)))
 217     (setf (slot-value class 'packed) (first packed))
 218     (when ref
 219       (setf (slot-value class 'ref) (first ref)))
 220     (when unref
 221       (setf (slot-value class 'unref) (first unref)))
 222     (call-next-method))
 223
 224   (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
 225     (case (getf initargs :allocation)
 226       (:alien (find-class 'direct-alien-slot-definition))
 227       (:virtual (find-class 'direct-virtual-alien-slot-definition))
 228       (t (call-next-method))))
 229
 230   (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs)
 231     (case (getf initargs :allocation)
 232       (:alien (find-class 'effective-alien-slot-definition))
 233       (:virtual (find-class 'effective-virtual-alien-slot-definition))
 234       (t (call-next-method))))
 235
 236
 237   (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
 238     (if (eq (slot-definition-allocation (first direct-slotds)) :alien)
 239         (nconc
 240          (list :offset (most-specific-slot-value direct-slotds 'offset))
 241          (call-next-method))
 242       (call-next-method)))
 243
 244   (defmethod slot-readable-p ((slotd effective-alien-slot-definition))
 245     (declare (ignore slotd))
 246     t)
 247
 248   (defmethod compute-slot-reader-function ((slotd effective-alien-slot-definition) &optional signal-unbound-p)
 249     (declare (ignore signal-unbound-p))
 250     (let* ((type (slot-definition-type slotd))
 251            (offset (slot-definition-offset slotd))
 252            (reader (reader-function type)))
 253       #'(lambda (object)
 254           (funcall reader (foreign-location object) offset))))
 255
 256   (defmethod slot-writable-p ((slotd effective-alien-slot-definition))
 257     (declare (ignore slotd))
 258     t)
 259
 260   (defmethod compute-slot-writer-function ((slotd effective-alien-slot-definition))
 261     (let* ((type (slot-definition-type slotd))
 262            (offset (slot-definition-offset slotd))
 263            (writer (writer-function type))
 264            (destroy (destroy-function type)))
 265       #'(lambda (value object)
 266           (let ((location (foreign-location object)))
 267             (funcall destroy location offset) ; destroy old value
 268             (funcall writer value location offset))
 269           value)))
 270
 271   (defmethod compute-slot-reader-function ((slotd effective-virtual-alien-slot-definition) &optional signal-unbound-p)
 272     (declare (ignore signal-unbound-p))
 273     (if (and (slot-boundp slotd 'getter) (stringp (slot-definition-getter slotd)))
 274         (let ((getter (slot-definition-getter slotd))
 275               (type (slot-definition-type slotd))
 276               (reader nil))
 277           #'(lambda (object)
 278               (unless reader
 279                 (setq reader (mkbinding getter type 'pointer)))
 280               (funcall reader (foreign-location object))))
 281       (call-next-method)))
 282
 283   (defmethod compute-slot-writer-function ((slotd effective-virtual-alien-slot-definition))
 284     (if (and (slot-boundp slotd 'setter) (stringp (slot-definition-setter slotd)))
 285         (let ((setter (slot-definition-setter slotd))
 286               (type (slot-definition-type slotd))
 287               (writer nil))
 288           #'(lambda (value object)
 289               (unless writer
 290                 (setq writer (mkbinding setter nil 'pointer type)))
 291               (funcall writer (foreign-location object) value)))
 292       (call-next-method)))
 293
 294   (defun adjust-offset (offset type &optional packed-p)
 295     (let ((alignment (type-alignment type)))
 296       (if (or packed-p (zerop (mod offset alignment)))
 297           offset
 298         (+ offset (- alignment (mod offset alignment))))))
 299
 300   (defmethod compute-slots ((class proxy-class))
 301     (let ((alien-slots (remove-if-not
 302                         #'(lambda (allocation) (eq allocation :alien))
 303                         (class-direct-slots class)
 304                         :key #'slot-definition-allocation)))
 305       (when alien-slots
 306         (loop
 307          with packed-p = (foreign-slots-packed-p class)
 308          for slotd in alien-slots
 309          as offset = (adjust-offset
 310                       (foreign-size (most-specific-proxy-superclass class))
 311                       (slot-definition-type slotd)
 312                       packed-p)
 313                      then (adjust-offset offset (slot-definition-type slotd) packed-p)
 314          do (if (slot-boundp slotd 'offset)
 315                 (setf offset (slot-value slotd 'offset))
 316               (setf (slot-value slotd 'offset) offset))
 317             (incf offset (size-of (slot-definition-type slotd))))))
 318     (call-next-method))
 319
 320   (defmethod validate-superclass ((class proxy-class) (super standard-class))
 321     (subtypep (class-name super) 'proxy))
 322
 323   (defmethod foreign-size ((class-name symbol))
 324     (foreign-size (find-class class-name))))
 325
 326 (defmethod foreign-size ((object proxy))
 327   (foreign-size (class-of object)))
 328
 329 (define-type-method alien-type ((type proxy))
 330   (declare (ignore type))
 331   (alien-type 'pointer))
 332
 333 (define-type-method size-of ((type proxy) &key inlined)
 334   (assert-not-inlined type inlined)
 335   (size-of 'pointer))
 336
 337 (define-type-method type-alignment ((type proxy) &key inlined)
 338   (assert-not-inlined type inlined)
 339   (type-alignment 'pointer))
 340
 341 (define-type-method from-alien-form ((type proxy) form &key (ref :free))
 342   (let ((class (type-expand type)))
 343     (ecase ref
 344       (:free `(ensure-proxy-instance ',class ,form :reference nil))
 345       (:copy `(ensure-proxy-instance ',class ,form))
 346       ((:static :temp) `(ensure-proxy-instance ',class ,form
 347                          :reference nil :finalize nil)))))
 348
 349 (define-type-method from-alien-function ((type proxy) &key (ref :free))
 350   (let ((class (type-expand type)))
 351     (ecase ref
 352       (:free
 353        #'(lambda (location)
 354            (ensure-proxy-instance class location :reference nil)))
 355       (:copy
 356        #'(lambda (location)
 357            (ensure-proxy-instance class location)))
 358       ((:static :temp)
 359        #'(lambda (location)
 360            (ensure-proxy-instance class location :reference nil :finalize nil))))))
 361
 362 (define-type-method to-alien-form ((type proxy) instance &optional copy-p)
 363   (if copy-p
 364       (let* ((class (type-expand type))
 365              (ref (reference-function class)))
 366         (if (symbolp ref)
 367             `(,ref (foreign-location ,instance))
 368           `(funcall (reference-function ',class)
 369             (foreign-location ,instance))))
 370     `(foreign-location ,instance)))
 371
 372 (define-type-method to-alien-function ((type proxy) &optional copy-p)
 373   (if copy-p
 374       (let ((ref (reference-function (type-expand type))))
 375         #'(lambda (instance)
 376             (funcall ref (foreign-location instance))))
 377     #'foreign-location))
 378
 379 (define-type-method writer-function ((type proxy) &key temp inlined)
 380   (assert-not-inlined type inlined)
 381   (if temp
 382       #'(lambda (instance location &optional (offset 0))
 383           (assert (null-pointer-p (ref-pointer location offset)))
 384           (setf (ref-pointer location offset) (foreign-location instance)))
 385     (let ((ref (reference-function (type-expand type))))
 386       #'(lambda (instance location &optional (offset 0))
 387           (assert (null-pointer-p (ref-pointer location offset)))
 388           (setf
 389            (ref-pointer location offset)
 390            (funcall ref (foreign-location instance)))))))
 391
 392 (define-type-method reader-function ((type proxy) &key (ref :read) inlined)
 393   (assert-not-inlined type inlined)
 394   (let ((class (type-expand type)))
 395     (ecase ref
 396       (:read
 397        #'(lambda (location &optional (offset 0))
 398            (let ((instance (ref-pointer location offset)))
 399              (unless (null-pointer-p instance)
 400                (ensure-proxy-instance class instance)))))
 401       (:peek
 402        #'(lambda (location &optional (offset 0))
 403            (let ((instance (ref-pointer location offset)))
 404              (unless (null-pointer-p instance)
 405                (ensure-proxy-instance class instance
 406                 :reference nil :finalize nil)))))
 407       (:get
 408        #'(lambda (location &optional (offset 0))
 409            (let ((instance (ref-pointer location offset)))
 410              (unless (null-pointer-p instance)
 411                (prog1
 412                    (ensure-proxy-instance class instance :reference nil)
 413                  (setf (ref-pointer location offset) (make-pointer 0))))))))))
 414
 415 (define-type-method destroy-function ((type proxy) &key temp inlined)
 416   (assert-not-inlined type inlined)
 417   (if temp
 418       #'(lambda (location &optional (offset 0))
 419           (setf (ref-pointer location offset) (make-pointer 0)))
 420     (let ((unref (unreference-function (type-expand type))))
 421       #'(lambda (location &optional (offset 0))
 422           (unless (null-pointer-p (ref-pointer location offset))
 423             (funcall unref (ref-pointer location offset))
 424             (setf (ref-pointer location offset) (make-pointer 0)))))))
 425
 426 (define-type-method copy-function ((type proxy) &key inlined)
 427   (assert-not-inlined type inlined)
 428   (let ((ref (reference-function (type-expand type))))
 429     #'(lambda (from to &optional (offset 0))
 430         (let ((instance (ref-pointer from offset)))
 431           (unless (null-pointer-p instance)
 432             (funcall ref instance))
 433           (setf (ref-pointer to offset) instance)))))
 434
 435 (define-type-method unbound-value ((type proxy))
 436   (declare (ignore type))
 437   nil)
 438
 439 (defun ensure-proxy-instance (class location &rest initargs)
 440   "Returns a proxy object representing the foreign object at the give
 441 location. If an existing proxy object is not found,
 442 MAKE-PROXY-INSTANCE is called to create a new one. A second return
 443 value indicates whether a new proxy was created or not."
 444   (unless (null-pointer-p location)
 445     (or
 446      #-debug-ref-counting(find-cached-instance location)
 447      #+debug-ref-counting
 448      (let ((instance (find-cached-instance location)))
 449        (when instance
 450          (format t "Object found in cache: ~A~%" instance)
 451          instance))
 452      (values
 453       (apply #'make-proxy-instance class location initargs)
 454       t))))
 455
 456 (defgeneric make-proxy-instance (class location &key reference finalize)
 457   (:documentation "Creates a new proxy object representing the foreign
 458 object at the give location."))
 459
 460 (defmethod make-proxy-instance ((class symbol) location &rest initargs)
 461   (apply #'make-proxy-instance (find-class class) location initargs))
 462
 463 (defmethod make-proxy-instance ((class proxy-class) location
 464                                 &key (reference t) (finalize t))
 465   (let ((instance
 466          (or
 467           (find-invalidated-instance class)
 468           (allocate-instance class))))
 469     (setf (foreign-location instance)
 470      (if reference
 471          (funcall (reference-function class) location)
 472        location))
 473     (finalize instance
 474      (if finalize
 475          (instance-finalizer instance)
 476        ;; We still need to remove the instance from the cache even if we
 477        ;; don't do normal finalization
 478        (let ((location (foreign-location instance)))
 479          #+(or cmu sbcl)
 480          #'(lambda ()
 481              (remove-cached-instance location))
 482          #+clisp
 483          #'(lambda (instance)
 484              (declare (ignore instance))
 485              (remove-cached-instance location)))))
 486     (cache-instance instance)
 487     instance))
 488
 489
 490 ;;;; Superclasses for wrapping of C structures
 491
 492 (defclass struct (proxy)
 493   ()
 494   (:metaclass proxy-class)
 495   (:size 0))
 496
 497 (defmethod allocate-foreign ((struct struct) &rest initargs)
 498   (declare (ignore initargs))
 499   (let ((size (foreign-size (class-of struct))))
 500     (if (zerop size)
 501         (error "~A has zero size" (class-of struct))
 502       (allocate-memory size))))
 503
 504
 505 ;;;; Metaclasses used for subclasses of struct
 506
 507 (defclass struct-class (proxy-class)
 508   ())
 509
 510 (defmethod shared-initialize ((class struct-class) names &rest initargs)
 511   (declare (ignore names initargs))
 512   (call-next-method)
 513   (let ((offsets nil) (copy-functions nil) (destroy-functions nil))
 514     (flet ((initialize-functions ()
 515              (loop
 516               for slotd in (class-slots class)
 517               as type = (slot-definition-type slotd)
 518               when (eq (slot-definition-allocation slotd) :alien)
 519               do (push (slot-definition-offset slotd) offsets)
 520                  (push (copy-function type) copy-functions)
 521                  (push (destroy-function type) destroy-functions))))
 522       (unless (slot-boundp class 'ref)
 523         (setf
 524          (slot-value class 'ref)
 525          #'(lambda (from &optional (to (allocate-memory (foreign-size class))))
 526              (assert (not (null-pointer-p from)))
 527              (unless offsets
 528                (initialize-functions))
 529              (loop
 530               for offset in offsets
 531               for copy in copy-functions
 532               do (funcall copy from to offset))
 533              to)))
 534       (unless (slot-boundp class 'unref)
 535         (setf (slot-value class 'unref)
 536          #'(lambda (location &optional inlined-p)
 537              (assert (not (null-pointer-p location)))
 538              (unless offsets
 539                (initialize-functions))
 540              (loop
 541               for offset in offsets
 542               for destroy in destroy-functions
 543               do (funcall destroy location offset))
 544              (unless inlined-p
 545                (deallocate-memory location))))))))
 546
 547
 548 (defmethod direct-slot-definition-class ((class struct-class) &rest initargs)
 549   (if (not (getf initargs :allocation))
 550       (find-class 'direct-alien-slot-definition)
 551     (call-next-method)))
 552
 553
 554 (defmethod compute-slots :around ((class struct-class))
 555   (let ((slots (call-next-method)))
 556     (when (and
 557            #?-(or (sbcl>= 0 9 8) (featurep :clisp))(class-finalized-p class)
 558            (not (slot-boundp class 'size)))
 559       (setf (slot-value class 'size)
 560        (or
 561         (loop
 562          for slotd in slots
 563          when (eq (slot-definition-allocation slotd) :alien)
 564          maximize (+
 565                    (slot-definition-offset slotd)
 566                    (size-of (slot-definition-type slotd))))
 567         0)))
 568     slots))
 569
 570 (define-type-method callback-wrapper ((type struct) var arg form)
 571   (let ((class (type-expand type)))
 572     `(let ((,var (ensure-proxy-instance ',class ,arg :finalize nil)))
 573        (unwind-protect
 574            ,form
 575          (invalidate-instance ,var)))))
 576
 577 (define-type-method size-of ((type struct) &key inlined)
 578   (if inlined
 579       (foreign-size type)
 580     (size-of 'pointer)))
 581
 582 (define-type-method type-alignment ((type struct) &key inlined)
 583   (if inlined
 584       (let ((slot1 (find-if
 585                     #'(lambda (slotd)
 586                         (eq (slot-definition-allocation slotd) :alien))
 587                     (class-slots (find-class type)))))
 588         (type-alignment (slot-definition-type slot1)))
 589     (type-alignment 'pointer)))
 590
 591 (define-type-method writer-function ((type struct) &key temp inlined)
 592   (if inlined
 593       (if temp
 594           (let ((size (size-of type :inlined t)))
 595             #'(lambda (instance location &optional (offset 0))
 596                 (copy-memory
 597                  (foreign-location instance) size
 598                  (pointer+ location offset))))
 599         (let ((ref (reference-function  (type-expand type))))
 600           #'(lambda (instance location &optional (offset 0))
 601               (funcall ref
 602                (foreign-location instance)
 603                (pointer+ location offset)))))
 604     (call-next-method)))
 605
 606 (define-type-method reader-function ((type struct) &key (ref :read) inlined)
 607   (if inlined
 608       (let ((class (type-expand type))
 609             (size (size-of type :inlined t)))
 610         (ecase ref
 611           (:read
 612            #'(lambda (location &optional (offset 0))
 613                (ensure-proxy-instance class (pointer+ location offset))))
 614           (:peek
 615            #'(lambda (location &optional (offset 0))
 616                (ensure-proxy-instance class (pointer+ location offset)
 617                 :reference nil :finalize nil)))
 618           (:get
 619            #'(lambda (location &optional (offset 0))
 620                (prog1
 621                    (ensure-proxy-instance class
 622                     (copy-memory (pointer+ location offset) size)
 623                     :reference nil)
 624                  (clear-memory (pointer+ location offset) size))))))
 625     (call-next-method)))
 626
 627 (define-type-method destroy-function ((type struct) &key temp inlined)
 628   (if inlined
 629       (let ((size (size-of type :inlined t)))
 630         (if temp
 631             #'(lambda (location &optional (offset 0))
 632                 (clear-memory (pointer+ location offset) size))
 633           (let ((unref (unreference-function  (type-expand type))))
 634             #'(lambda (location &optional (offset 0))
 635                 (funcall unref (pointer+ location offset) t)))))
 636     (call-next-method)))
 637
 638 (define-type-method copy-function ((type struct) &key inlined)
 639   (if inlined
 640         (let ((ref (reference-function  (type-expand type))))
 641           #'(lambda (from to &optional (offset 0))
 642               (funcall ref (pointer+ from offset) (pointer+ to offset))))
 643     (call-next-method)))