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

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