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