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

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000 Espen S. Johnsen <espejohn@online.no>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: gtype.lisp,v 1.4 2000/09/04 22:04:24 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22 (use-prefix "g")
  23
  24
  25 ;;;;
  26
  27 (deftype type-number () '(unsigned 32))
  28
  29 (define-foreign ("g_type_name" alien-type-name) (type) (static string)
  30   ((find-type-number type) type-number))
  31
  32 (define-foreign %type-from-name () type-number
  33   (name string))
  34
  35 ;(define-foreign type-parent () type-number
  36 ;  (type type-number))
  37
  38 (define-foreign type-instance-size (type) int
  39   ((find-type-number type) type-number))
  40
  41 (define-foreign type-create-instance (type) pointer
  42   ((find-type-number type) type-number))
  43
  44 (define-foreign type-free-instance () nil
  45   (instance pointer))
  46
  47
  48 (defvar *type-to-number-hash* (make-hash-table))
  49 (defvar *number-to-type-hash* (make-hash-table))
  50
  51 (defun type-number-from-alien-name (name &optional (error t))
  52   (if (string= name "invalid")
  53       0
  54     (let ((type-number (%type-from-name name)))
  55       (cond
  56        ((and (zerop type-number) error)
  57         (error "Invalid alien type name: ~A" name))
  58        ((zerop type-number) nil)
  59        (t type-number)))))
  60
  61 (defun (setf alien-type-name) (alien-name type)
  62   (let ((type-name (ensure-type-name type))
  63         (type-number (type-number-from-alien-name alien-name)))
  64     (setf (gethash type-number *number-to-type-hash*) type-name)
  65     (setf (gethash type-name *type-to-number-hash*) type-number)))
  66
  67 (defun (setf find-type-number) (type-number type)
  68   (setf (gethash (ensure-type-name type) *type-to-number-hash*) type-number))
  69
  70 (defun find-type-number (type)
  71   (etypecase type
  72     (integer type)
  73     (symbol (gethash type *type-to-number-hash*))
  74     (pcl::class (gethash (class-name type) *type-to-number-hash*))))
  75
  76 (defun type-from-number (type-number)
  77   (gethash type-number *number-to-type-hash*))
  78
  79 (defun type-number-of (object)
  80   (find-type-number (type-of object)))
  81
  82
  83
  84 ;;;; Superclass for all metaclasses implementing some sort of virtual slots
  85
  86 (eval-when (:compile-toplevel :load-toplevel :execute)
  87   (defclass virtual-class (pcl::standard-class))
  88
  89   (defclass direct-virtual-slot-definition (standard-direct-slot-definition)
  90     ((location
  91       :reader slot-definition-location
  92       :initarg :location)))
  93
  94   (defclass effective-virtual-slot-definition
  95     (standard-effective-slot-definition)))
  96
  97
  98 (defmethod direct-slot-definition-class ((class virtual-class) initargs)
  99   (if (eq (getf initargs :allocation) :virtual)
 100       (find-class 'direct-virtual-slot-definition)
 101     (call-next-method)))
 102
 103
 104 (defmethod effective-slot-definition-class ((class virtual-class) initargs)
 105   (if (eq (getf initargs :allocation) :virtual)
 106       (find-class 'effective-virtual-slot-definition)
 107     (call-next-method)))
 108
 109
 110 (defun %direct-slot-definitions-slot-value (slotds slot &optional default)
 111   (let ((slotd
 112          (find-if
 113           #'(lambda (slotd)
 114               (and
 115                (slot-exists-p slotd slot)
 116                (slot-boundp slotd slot)))
 117           slotds)))
 118     (if slotd
 119         (slot-value slotd slot)
 120       default)))
 121
 122
 123 (defgeneric compute-virtual-slot-location (class slotd direct-slotds))
 124
 125 (defmethod compute-virtual-slot-location
 126     ((class virtual-class)
 127      (slotd effective-virtual-slot-definition)
 128      direct-slotds)
 129     (let ((location
 130            (%direct-slot-definitions-slot-value direct-slotds 'location)))
 131       (if (and location (symbolp location))
 132           (list location `(setf ,location))
 133         location)))
 134
 135
 136 (defmethod compute-effective-slot-definition
 137     ((class virtual-class) direct-slotds)
 138   (let ((slotd (call-next-method)))
 139     (when (typep slotd 'effective-virtual-slot-definition)
 140       (setf
 141        (slot-value slotd 'pcl::location)
 142        (compute-virtual-slot-location class slotd direct-slotds)))
 143     slotd))
 144
 145
 146 (defmethod slot-value-using-class
 147     ((class virtual-class) (object standard-object)
 148      (slotd effective-virtual-slot-definition))
 149   (let ((reader (first (slot-definition-location slotd))))
 150     (if reader
 151         (funcall reader object)
 152       (slot-unbound class object (slot-definition-name slotd)))))
 153
 154
 155 (defmethod slot-boundp-using-class
 156     ((class virtual-class) (object standard-object)
 157      (slotd effective-virtual-slot-definition))
 158    (and (first (slot-definition-location slotd)) t))
 159
 160
 161
 162 (defmethod (setf slot-value-using-class)
 163     (value (class virtual-class) (object standard-object)
 164      (slotd effective-virtual-slot-definition))
 165   (let ((writer (second (slot-definition-location slotd))))
 166     (cond
 167      ((null writer)
 168       (error
 169        "Can't set read-only slot ~A in ~A"
 170        (slot-definition-name slotd)
 171        object))
 172      ((or (functionp writer) (symbolp writer))
 173       (funcall writer value object)
 174       object)
 175      (t
 176       (funcall (fdefinition writer) value object)
 177       object))))
 178
 179
 180 (defmethod validate-superclass
 181     ((class virtual-class) (super pcl::standard-class))
 182   t)
 183
 184
 185
 186 ;;;; Superclass for wrapping of C structures
 187
 188 (eval-when (:compile-toplevel :load-toplevel :execute)
 189   (defclass alien-instance ()
 190     ((location
 191       :reader alien-instance-location
 192       :type system-area-pointer)))
 193
 194   (defgeneric allocate-alien-storage (class))
 195   (defgeneric reference-instance (object))
 196   (defgeneric unreference-instance (object))
 197   (defgeneric from-alien-initialize-instance (object &rest initargs))
 198   (defgeneric instance-finalizer (object)))
 199
 200
 201 (internal *instance-cache*)
 202 (defvar *instance-cache* (make-hash-table :test #'eql))
 203
 204 (defun cache-instance (object)
 205   (setf
 206    (gethash (system:sap-int (alien-instance-location object)) *instance-cache*)
 207    (ext:make-weak-pointer object)))
 208
 209 (defun find-cached-instance (location)
 210   (let ((ref (gethash (system:sap-int location) *instance-cache*)))
 211     (when ref
 212       (ext:weak-pointer-value ref))))
 213
 214 (defun remove-cached-instance (location)
 215   (remhash (system:sap-int location) *instance-cache*))
 216
 217
 218 (defmethod initialize-instance :before ((instance alien-instance)
 219                                         &rest initargs &key)
 220   (declare (ignore initargs))
 221   (setf
 222    (slot-value instance 'location)
 223    (allocate-alien-storage (class-of instance)))
 224   (cache-instance instance)
 225   (ext:finalize instance (instance-finalizer instance)))
 226
 227
 228 (defmethod from-alien-initialize-instance ((instance alien-instance)
 229                                            &rest initargs &key location)
 230   (declare (ignore initargs))
 231   (setf (slot-value instance 'location) location)
 232   (cache-instance instance))
 233
 234
 235 (deftype-method translate-type-spec alien-instance (type-spec)
 236   (declare (ignore type-spec))
 237   (translate-type-spec 'pointer))
 238
 239 (deftype-method size-of alien-instance (type-spec)
 240   (declare (ignore type-spec))
 241   (size-of 'pointer))
 242
 243
 244
 245 ;;;; Metaclass used for subclasses of alien-instance
 246
 247 (eval-when (:compile-toplevel :load-toplevel :execute)
 248   (defclass alien-class (virtual-class)
 249     ((size
 250       :reader alien-class-size)))
 251
 252   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
 253     ((allocation
 254       :initform :alien)
 255      (offset
 256       :reader slot-definition-offset
 257       :initarg :offset
 258       :initform 0)))
 259
 260   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
 261     ((offset
 262       :reader slot-definition-offset)))
 263
 264   (defclass effective-virtual-alien-slot-definition
 265     (effective-virtual-slot-definition))
 266
 267
 268   (defmethod alien-class-superclass ((class alien-class))
 269     (find-if
 270      #'(lambda (class)
 271          (subtypep (class-name class) 'alien-instance))
 272      (pcl::class-direct-superclasses class)))
 273
 274
 275   (defmethod shared-initialize ((class alien-class) names
 276                                 &rest initargs &key size alien-name name)
 277     (declare (ignore initargs))
 278     (call-next-method)
 279
 280     (when alien-name
 281       (setf (alien-type-name (or name (class-name class))) (first alien-name)))
 282     (when size
 283       (setf (slot-value class 'size) (first size))))
 284
 285
 286   (defmethod shared-initialize :after ((class alien-class) names
 287                                        &rest initargs &key)
 288     (declare (ignore initargs names))
 289     (let* ((super (alien-class-superclass class))
 290            (actual-size
 291             (if (eq (class-name super) 'alien-instance)
 292                 0
 293               (alien-class-size super))))
 294       (dolist (slotd (class-slots class))
 295         (when (eq (slot-definition-allocation slotd) :alien)
 296           (with-slots (offset type) slotd
 297             (setq actual-size (max actual-size (+ offset (size-of type)))))))
 298       (cond
 299        ((not (slot-boundp class 'size))
 300         (setf (slot-value class 'size) actual-size))
 301        ((> actual-size (slot-value class 'size))
 302         (warn "The actual size of class ~A is lager than specified" class)))))
 303
 304
 305   (defmethod direct-slot-definition-class ((class alien-class) initargs)
 306     (case (getf initargs :allocation)
 307       ((nil :alien) (find-class 'direct-alien-slot-definition))
 308 ;      (:instance (error "Allocation :instance not allowed in class ~A" class))
 309       (t (call-next-method))))
 310
 311
 312   (defmethod effective-slot-definition-class ((class alien-class) initargs)
 313     (case (getf initargs :allocation)
 314       (:alien (find-class 'effective-alien-slot-definition))
 315       (:virtual (find-class 'effective-virtual-alien-slot-definition))
 316       (t (call-next-method))))
 317
 318
 319   (defmethod compute-virtual-slot-location
 320       ((class alien-class) (slotd effective-alien-slot-definition)
 321        direct-slotds)
 322     (with-slots (offset type) slotd
 323       (setf offset (%direct-slot-definitions-slot-value direct-slotds 'offset))
 324       (let ((reader (get-reader-function type))
 325             (writer (get-writer-function type))
 326             (destroy (get-destroy-function type)))
 327         (list
 328          #'(lambda (object)
 329              (funcall reader (alien-instance-location object) offset))
 330          #'(lambda (value object)
 331              (let ((location (alien-instance-location object)))
 332                (funcall destroy location offset)
 333                (funcall writer value location offset)))))))
 334
 335
 336   (defmethod compute-virtual-slot-location
 337       ((class alien-class)
 338        (slotd effective-virtual-alien-slot-definition)
 339        direct-slotds)
 340     (let ((location (call-next-method)))
 341       (if (or (stringp location) (consp location))
 342           (destructuring-bind (reader &optional writer) (mklist location)
 343             (with-slots (type) slotd
 344               (list
 345                (if (stringp reader)
 346                    (let* ((alien-type (translate-type-spec type))
 347                           (alien
 348                            (alien::%heap-alien
 349                             (alien::make-heap-alien-info
 350                              :type (alien::parse-alien-type
 351                                     `(function ,alien-type system-area-pointer))
 352                              :sap-form (system:foreign-symbol-address reader))))
 353                           (from-alien (get-from-alien-function type)))
 354                      #'(lambda (object)
 355                          (funcall
 356                           from-alien
 357                           (alien-funcall
 358                            alien (alien-instance-location object)))))
 359                  reader)
 360                (if (stringp writer)
 361                    (let* ((alien-type (translate-type-spec type))
 362                           (alien
 363                            (alien::%heap-alien
 364                             (alien::make-heap-alien-info
 365                              :type (alien::parse-alien-type
 366                                     `(function
 367                                       void system-area-pointer ,alien-type))
 368                              :sap-form (system:foreign-symbol-address writer))))
 369                           (to-alien (get-to-alien-function type))
 370                           (cleanup  (get-cleanup-function type)))
 371                      #'(lambda (value object)
 372                          (let ((alien-value (funcall to-alien value))
 373                                (location (alien-instance-location object)))
 374                            (alien-funcall alien location alien-value)
 375                            (funcall cleanup alien-value))))
 376                  writer))))
 377         location)))
 378
 379
 380   (defmethod compute-slots ((class alien-class))
 381     ;; Translating the user supplied relative (to previous slot) offsets
 382     ;; to absolute offsets.
 383     ;; This code is broken and have to be fixed for real use.
 384     (with-slots (direct-slots) class
 385       (let* ((super (alien-class-superclass class))
 386              (slot-offset
 387               (if (eq (class-name super) 'alien-instance)
 388                   0
 389                 (alien-class-size super))))
 390         (dolist (slotd direct-slots)
 391           (when (eq (slot-definition-allocation slotd) :alien)
 392             (with-slots (offset type) slotd
 393               (setf
 394                offset (+ slot-offset offset)
 395                slot-offset (+ offset (size-of type)))))))
 396
 397       ;; Reverse the direct slot definitions so the effective slots
 398       ;; will be in correct order.
 399       (setf direct-slots (reverse direct-slots))
 400       ;; This nreverse caused me so much frustration that I leave it
 401       ;; here just as a reminder of what not to do.
 402 ;      (setf direct-slots (nreverse direct-slots))
 403       )
 404     (call-next-method))
 405
 406
 407   (defmethod validate-superclass ((class alien-class)
 408                                   (super pcl::standard-class))
 409      (subtypep (class-name super) 'alien-instance))
 410
 411   (defgeneric make-instance-from-alien (class location &rest initargs &key)))
 412
 413 (defmethod make-instance-from-alien ((class symbol) location
 414                                      &rest initargs &key)
 415   (apply #'make-instance-from-alien (find-class class) location initargs))
 416
 417 (defmethod make-instance-from-alien ((class alien-class) location
 418                                      &rest initargs &key)
 419   (let ((instance (allocate-instance class)))
 420     (apply
 421      #'from-alien-initialize-instance
 422      instance :location location initargs)
 423     instance))
 424
 425 (defun ensure-alien-instance (class location &rest initargs)
 426   (or
 427    (find-cached-instance location)
 428    (apply #'make-instance-from-alien class location initargs)))
 429
 430 (defmethod allocate-alien-storage ((class alien-class))
 431   (allocate-memory (alien-class-size class)))
 432
 433
 434
 435 ;;;; Superclass for wrapping structures with reference counting
 436
 437 (eval-when (:compile-toplevel :load-toplevel :execute)
 438   (defclass alien-object (alien-instance)
 439     ()
 440     (:metaclass alien-class)
 441     (:size 0)))
 442
 443 (define-type-method-fun alien-ref (type-spec))
 444 (define-type-method-fun alien-unref (type-spec))
 445
 446 (defmethod from-alien-initialize-instance ((object alien-object)
 447                                            &rest initargs &key)
 448   (declare (ignore initargs))
 449   (call-next-method)
 450   (reference-instance object))
 451
 452 (defmethod instance-finalizer ((object alien-object))
 453   (let ((location (alien-instance-location object))
 454         (unref (fdefinition (alien-unref (class-of object)))))
 455     (declare (type system-area-pointer location) (type function unref))
 456     #'(lambda ()
 457         (remove-cached-instance location)
 458         (funcall unref location))))
 459
 460 (defmethod reference-instance ((object alien-object))
 461   (funcall (alien-ref (class-of object)) object)
 462   object)
 463
 464 (defmethod unreference-instance ((object alien-object))
 465   (funcall (alien-unref (class-of object)) object)
 466   nil)
 467
 468 (deftype-method translate-to-alien
 469     alien-object (type-spec object &optional copy)
 470   (if copy
 471       `(,(alien-ref type-spec) ,object)
 472     `(alien-instance-location ,object)))
 473
 474 (deftype-method translate-from-alien
 475     alien-object (type-spec location &optional alloc)
 476   ;; Reference counted objects are always treated as if alloc were :reference
 477   (declare (ignore alloc))
 478   `(let ((location ,location))
 479      (unless (null-pointer-p location)
 480        (ensure-alien-instance ',type-spec location))))
 481
 482 (deftype-method
 483     cleanup-alien alien-object (type-spec sap &optional copied)
 484   (when copied
 485     `(let ((sap ,sap))
 486        (unless (null-pointer-p sap)
 487          (,(alien-unref type-spec) sap)))))
 488
 489
 490
 491 ;;;; Superclass for wrapping of non-refcounted structures
 492
 493 (eval-when (:compile-toplevel :load-toplevel :execute)
 494   (defclass alien-structure (alien-instance)
 495     ((static
 496       :allocation :instance
 497       :reader alien-structure-static-p
 498       :initform nil
 499       :type boolean))
 500     (:metaclass alien-class)
 501     (:size 0)))
 502
 503 (define-type-method-fun alien-copier (type-spec))
 504 (define-type-method-fun alien-deallocator (type-spec))
 505
 506 (defmethod from-alien-initialize-instance ((structure alien-structure)
 507                                            &rest initargs &key static)
 508   (declare (ignore initargs))
 509   (call-next-method)
 510   (setf (slot-value structure 'static) static))
 511
 512 (defmethod instance-finalizer ((structure alien-structure))
 513   (let ((location (alien-instance-location structure)))
 514     (declare (type system-area-pointer location))
 515     (if (alien-structure-static-p structure)
 516         #'(lambda ()
 517             (remove-cached-instance location))
 518       (let ((deallocator
 519              (fdefinition (alien-deallocator (class-of structure)))))
 520         (declare (type function deallocator))
 521         #'(lambda ()
 522             (remove-cached-instance location)
 523             (funcall deallocator location))))))
 524
 525
 526 (deftype-method alien-copier alien-structure (type-spec)
 527   (declare (ignore type-spec))
 528   'copy-memory)
 529
 530 (deftype-method alien-deallocator alien-structure (type-spec)
 531   (declare (ignore type-spec))
 532   'deallocate-memory)
 533
 534 (deftype-method translate-to-alien
 535     alien-structure (type-spec object &optional copy)
 536   `(let ((object ,object))
 537      (if (and ,copy (not (alien-structure-static-p object)))
 538          (,(alien-copier type-spec)
 539           `(alien-instance-location object)
 540           ,(alien-class-size (find-class type-spec)))
 541        (alien-instance-location object))))
 542
 543 (deftype-method translate-from-alien
 544     alien-structure (type-spec location &optional (alloc :reference))
 545   `(let ((location ,location))
 546      (unless (null-pointer-p location)
 547        ,(ecase alloc
 548           (:copy `(ensure-alien-instance ',type-spec location))
 549           (:static `(ensure-alien-instance ',type-spec location :static t))
 550           (:reference
 551            `(ensure-alien-instance
 552              ',type-spec
 553              `(,(alien-copier type-spec)
 554                location ,(alien-class-size (find-class type-spec)))))))))
 555
 556 (deftype-method cleanup-alien alien-structure (type-spec sap &optional copied)
 557   (when copied
 558     `(let ((sap ,sap))
 559        (unless (or
 560                 (null-pointer-p sap)
 561                 (alien-structure-static-p (find-cached-instance sap)))
 562          (,(alien-deallocator type-spec) sap)))))
 563
 564
 565
 566 ;;;; Superclass for static structures such as gdk:visual
 567
 568 (defclass static-structure (alien-structure)
 569   ()
 570   (:metaclass alien-class)
 571   (:size 0))
 572
 573
 574 (defmethod from-alien-initialize-instance ((structure alien-structure)
 575                                       &rest initargs)
 576   (declare (ignore initargs))
 577   (call-next-method)
 578   (setf (slot-value structure 'static) t))
 579
 580
 581
 582 ;;;; Superclass wrapping types in the glib type system
 583
 584 (eval-when (:compile-toplevel :load-toplevel :execute)
 585   (defclass gtype (alien-object)
 586     ()
 587     (:metaclass alien-class)
 588     (:size 4 #|(size-of 'pointer)|#)))
 589
 590
 591 (defun %alien-instance-type-number (location)
 592   (let ((class (sap-ref-sap location 0)))
 593     (sap-ref-unsigned class 0)))
 594
 595
 596 (deftype-method translate-from-alien gtype (type-spec location &optional alloc)
 597   (declare (ignore type-spec alloc))
 598   `(let ((location ,location))
 599      (unless (null-pointer-p location)
 600        (ensure-alien-instance
 601         (type-from-number (%alien-instance-type-number location))
 602         location))))
 603
 604
 605
 606 ;;;; Metaclass for subclasses of gtype-class
 607
 608 (eval-when (:compile-toplevel :load-toplevel :execute)
 609   (defclass gtype-class (alien-class)))
 610
 611
 612 (defmethod shared-initialize ((class gtype-class) names
 613                               &rest initargs &key name)
 614   (declare (ignore initargs names))
 615   (call-next-method)
 616   (setf
 617    (slot-value class 'size)
 618    (type-instance-size (find-type-number (or name (class-name class))))))
 619
 620
 621 (defmethod validate-superclass
 622     ((class gtype-class) (super pcl::standard-class))
 623   (subtypep (class-name super) 'gtype))
 624
 625
 626 (defmethod allocate-alien-storage ((class gtype-class))
 627   (type-create-instance (find-type-number class)))
 628
 629
 630 ;;;; Initializing type numbers
 631
 632 (setf (alien-type-name 'invalid) "invalid")
 633 (setf (alien-type-name 'char) "gchar")
 634 (setf (alien-type-name 'unsigned-char) "guchar")
 635 (setf (alien-type-name 'boolean) "gboolean")
 636 (setf (alien-type-name 'int) "gint")
 637 (setf (alien-type-name 'unsigned-int) "guint")
 638 (setf (alien-type-name 'long) "glong")
 639 (setf (alien-type-name 'unsigned-long) "gulong")
 640 (setf (alien-type-name 'enum) "GEnum")
 641 (setf (alien-type-name 'flags) "GFlags")
 642 (setf (alien-type-name 'single-float) "gfloat")
 643 (setf (alien-type-name 'double-float) "gdouble")
 644 (setf (alien-type-name 'string) "gstring")
 645 (setf (find-type-number 'fixnum) (find-type-number 'int))