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