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