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.3 2000-08-23 14:27:41 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   'system-area-pointer)
 238
 239
 240
 241 ;;;; Metaclass used for subclasses of alien-instance
 242
 243 (eval-when (:compile-toplevel :load-toplevel :execute)
 244   (defclass alien-class (virtual-class)
 245     ((size
 246       :reader alien-class-size)))
 247
 248   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
 249     ((allocation
 250       :initform :alien)
 251      (offset
 252       :reader slot-definition-offset
 253       :initarg :offset
 254       :initform 0)))
 255
 256   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
 257     ((offset
 258       :reader slot-definition-offset)))
 259
 260   (defclass effective-virtual-alien-slot-definition
 261     (effective-virtual-slot-definition))
 262
 263
 264   (defmethod alien-class-superclass ((class alien-class))
 265     (find-if
 266      #'(lambda (class)
 267          (subtypep (class-name class) 'alien-instance))
 268      (pcl::class-direct-superclasses class)))
 269
 270
 271   (defmethod shared-initialize ((class alien-class) names
 272                                 &rest initargs &key size alien-name name)
 273     (declare (ignore initargs))
 274     (call-next-method)
 275
 276     (when alien-name
 277       (setf (alien-type-name (or name (class-name class))) (first alien-name)))
 278     (when size
 279       (setf (slot-value class 'size) (first size))))
 280
 281
 282   (defmethod shared-initialize :after ((class alien-class) names
 283                                        &rest initargs &key)
 284     (declare (ignore initargs names))
 285     (let* ((super (alien-class-superclass class))
 286            (actual-size
 287             (if (eq (class-name super) 'alien-instance)
 288                 0
 289               (alien-class-size super))))
 290       (dolist (slotd (class-slots class))
 291         (when (eq (slot-definition-allocation slotd) :alien)
 292           (with-slots (offset type) slotd
 293             (setq actual-size (max actual-size (+ offset (size-of type)))))))
 294       (cond
 295        ((not (slot-boundp class 'size))
 296         (setf (slot-value class 'size) actual-size))
 297        ((> actual-size (slot-value class 'size))
 298         (warn "The actual size of class ~A is lager than specified" class)))))
 299
 300
 301   (defmethod direct-slot-definition-class ((class alien-class) initargs)
 302     (case (getf initargs :allocation)
 303       ((nil :alien) (find-class 'direct-alien-slot-definition))
 304 ;      (:instance (error "Allocation :instance not allowed in class ~A" class))
 305       (t (call-next-method))))
 306
 307
 308   (defmethod effective-slot-definition-class ((class alien-class) initargs)
 309     (case (getf initargs :allocation)
 310       (:alien (find-class 'effective-alien-slot-definition))
 311       (:virtual (find-class 'effective-virtual-alien-slot-definition))
 312       (t (call-next-method))))
 313
 314
 315   (defmethod compute-virtual-slot-location
 316       ((class alien-class) (slotd effective-alien-slot-definition)
 317        direct-slotds)
 318     (with-slots (offset type) slotd
 319       (setf offset (%direct-slot-definitions-slot-value direct-slotds 'offset))
 320       (let ((reader (get-reader-function type))
 321             (writer (get-writer-function type))
 322             (destroy (get-destroy-function type)))
 323         (list
 324          #'(lambda (object)
 325              (funcall reader (alien-instance-location object) offset))
 326          #'(lambda (value object)
 327              (let ((location (alien-instance-location object)))
 328                (funcall destroy location offset)
 329                (funcall writer value location offset)))))))
 330
 331
 332   (defmethod compute-virtual-slot-location
 333       ((class alien-class)
 334        (slotd effective-virtual-alien-slot-definition)
 335        direct-slotds)
 336     (let ((location (call-next-method)))
 337       (if (or (stringp location) (consp location))
 338           (destructuring-bind (reader &optional writer) (mklist location)
 339             (with-slots (type) slotd
 340               (list
 341                (if (stringp reader)
 342                    (let* ((alien-type (translate-type-spec type))
 343                           (alien
 344                            (alien::%heap-alien
 345                             (alien::make-heap-alien-info
 346                              :type (alien::parse-alien-type
 347                                     `(function ,alien-type system-area-pointer))
 348                              :sap-form (system:foreign-symbol-address reader))))
 349                           (from-alien (get-from-alien-function type)))
 350                      #'(lambda (object)
 351                          (funcall
 352                           from-alien
 353                           (alien-funcall
 354                            alien (alien-instance-location object)))))
 355                  reader)
 356                (if (stringp writer)
 357                    (let* ((alien-type (translate-type-spec type))
 358                           (alien
 359                            (alien::%heap-alien
 360                             (alien::make-heap-alien-info
 361                              :type (alien::parse-alien-type
 362                                     `(function
 363                                       void ,alien-type system-area-pointer))
 364                              :sap-form (system:foreign-symbol-address writer))))
 365                           (to-alien (get-to-alien-function type))
 366                           (cleanup  (get-cleanup-function type)))
 367                      #'(lambda (value object)
 368                          (let ((alien-value (funcall to-alien value))
 369                                (location (alien-instance-location object)))
 370                            (alien-funcall alien location alien-value)
 371                            (funcall cleanup alien-value))))
 372                  writer))))
 373         location)))
 374
 375
 376   (defmethod compute-slots ((class alien-class))
 377     ;; Translating the user supplied relative (to previous slot) offsets
 378     ;; to absolute offsets.
 379     ;; This code is broken and have to be fixed for real use.
 380     (with-slots (direct-slots) class
 381       (let* ((super (alien-class-superclass class))
 382              (slot-offset
 383               (if (eq (class-name super) 'alien-instance)
 384                   0
 385                 (alien-class-size super))))
 386         (dolist (slotd direct-slots)
 387           (when (eq (slot-definition-allocation slotd) :alien)
 388             (with-slots (offset type) slotd
 389               (setf
 390                offset (+ slot-offset offset)
 391                slot-offset (+ offset (size-of type)))))))
 392
 393       ;; Reverse the direct slot definitions so the effective slots
 394       ;; will be in correct order.
 395       (setf direct-slots (reverse direct-slots))
 396       ;; This nreverse caused me so much frustration that I leave it
 397       ;; here just as a reminder of what not to do.
 398 ;      (setf direct-slots (nreverse direct-slots))
 399       )
 400     (call-next-method))
 401
 402
 403   (defmethod validate-superclass ((class alien-class)
 404                                   (super pcl::standard-class))
 405      (subtypep (class-name super) 'alien-instance))
 406
 407   (defgeneric make-instance-from-alien (class location &rest initargs &key)))
 408
 409 (defmethod make-instance-from-alien ((class symbol) location
 410                                      &rest initargs &key)
 411   (apply #'make-instance-from-alien (find-class class) location initargs))
 412
 413 (defmethod make-instance-from-alien ((class alien-class) location
 414                                      &rest initargs &key)
 415   (let ((instance (allocate-instance class)))
 416     (apply
 417      #'from-alien-initialize-instance
 418      instance :location location initargs)
 419     instance))
 420
 421 (defun ensure-alien-instance (class location &rest initargs)
 422   (or
 423    (find-cached-instance location)
 424    (apply #'make-instance-from-alien class location initargs)))
 425
 426 (defmethod allocate-alien-storage ((class alien-class))
 427   (allocate-memory (alien-class-size class)))
 428
 429
 430
 431 ;;;; Superclass for wrapping structures with reference counting
 432
 433 (eval-when (:compile-toplevel :load-toplevel :execute)
 434   (defclass alien-object (alien-instance)
 435     ()
 436     (:metaclass alien-class)
 437     (:size 0)))
 438
 439 (define-type-method-fun alien-ref (type-spec))
 440 (define-type-method-fun alien-unref (type-spec))
 441
 442 (defmethod from-alien-initialize-instance ((object alien-object)
 443                                            &rest initargs &key)
 444   (declare (ignore initargs))
 445   (call-next-method)
 446   (reference-instance object))
 447
 448 (defmethod instance-finalizer ((object alien-object))
 449   (let ((location (alien-instance-location object))
 450         (unref (fdefinition (alien-unref (class-of object)))))
 451     (declare (type system-area-pointer location) (type function unref))
 452     #'(lambda ()
 453         (remove-cached-instance location)
 454         (funcall unref location))))
 455
 456 (defmethod reference-instance ((object alien-object))
 457   (funcall (alien-ref (class-of object)) object)
 458   object)
 459
 460 (defmethod unreference-instance ((object alien-object))
 461   (funcall (alien-unref (class-of object)) object)
 462   nil)
 463
 464 (deftype-method translate-to-alien
 465     alien-object (type-spec object &optional copy)
 466   (if copy
 467       `(,(alien-ref type-spec) ,object)
 468     `(alien-instance-location ,object)))
 469
 470 (deftype-method translate-from-alien
 471     alien-object (type-spec location &optional alloc)
 472   ;; Reference counted objects are always treated as if alloc were :reference
 473   (declare (ignore alloc))
 474   `(let ((location ,location))
 475      (unless (null-pointer-p location)
 476        (ensure-alien-instance ',type-spec location))))
 477
 478 (deftype-method
 479     cleanup-alien alien-object (type-spec sap &optional copied)
 480   (when copied
 481     `(let ((sap ,sap))
 482        (unless (null-pointer-p sap)
 483          (,(alien-unref type-spec) sap)))))
 484
 485
 486
 487 ;;;; Superclass for wrapping of non-refcounted structures
 488
 489 (eval-when (:compile-toplevel :load-toplevel :execute)
 490   (defclass alien-structure (alien-instance)
 491     ((static
 492       :allocation :instance
 493       :reader alien-structure-static-p
 494       :initform nil
 495       :type boolean))
 496     (:metaclass alien-class)
 497     (:size 0)))
 498
 499 (define-type-method-fun alien-copier (type-spec))
 500 (define-type-method-fun alien-deallocator (type-spec))
 501
 502 (defmethod from-alien-initialize-instance ((structure alien-structure)
 503                                            &rest initargs &key static)
 504   (declare (ignore initargs))
 505   (call-next-method)
 506   (setf (slot-value structure 'static) static))
 507
 508 (defmethod instance-finalizer ((structure alien-structure))
 509   (let ((location (alien-instance-location structure)))
 510     (declare (type system-area-pointer location))
 511     (if (alien-structure-static-p structure)
 512         #'(lambda ()
 513             (remove-cached-instance location))
 514       (let ((deallocator
 515              (fdefinition (alien-deallocator (class-of structure)))))
 516         (declare (type function deallocator))
 517         #'(lambda ()
 518             (remove-cached-instance location)
 519             (funcall deallocator location))))))
 520
 521
 522 (deftype-method alien-copier alien-structure (type-spec)
 523   (declare (ignore type-spec))
 524   'copy-memory)
 525
 526 (deftype-method alien-deallocator alien-structure (type-spec)
 527   (declare (ignore type-spec))
 528   'deallocate-memory)
 529
 530 (deftype-method translate-to-alien
 531     alien-structure (type-spec object &optional copy)
 532   `(let ((object ,object))
 533      (if (and ,copy (not (alien-structure-static-p object)))
 534          (,(alien-copier type-spec)
 535           `(alien-instance-location object)
 536           ,(alien-class-size (find-class type-spec)))
 537        (alien-instance-location object))))
 538
 539 (deftype-method translate-from-alien
 540     alien-structure (type-spec location &optional (alloc :reference))
 541   `(let ((location ,location))
 542      (unless (null-pointer-p location)
 543        ,(ecase alloc
 544           (:copy `(ensure-alien-instance ',type-spec location))
 545           (:static `(ensure-alien-instance ',type-spec location :static t))
 546           (:reference
 547            `(ensure-alien-instance
 548              ',type-spec
 549              `(,(alien-copier type-spec)
 550                location ,(alien-class-size (find-class type-spec)))))))))
 551
 552 (deftype-method cleanup-alien alien-structure (type-spec sap &optional copied)
 553   (when copied
 554     `(let ((sap ,sap))
 555        (unless (or
 556                 (null-pointer-p sap)
 557                 (alien-structure-static-p (find-cached-instance sap)))
 558          (,(alien-deallocator type-spec) sap)))))
 559
 560
 561
 562 ;;;; Superclass for static structures such as gdk:visual
 563
 564 (defclass static-structure (alien-structure)
 565   ()
 566   (:metaclass alien-class)
 567   (:size 0))
 568
 569
 570 (defmethod from-alien-initialize-instance ((structure alien-structure)
 571                                       &rest initargs)
 572   (declare (ignore initargs))
 573   (call-next-method)
 574   (setf (slot-value structure 'static) t))
 575
 576
 577
 578 ;;;; Superclass wrapping types in the glib type system
 579
 580 (eval-when (:compile-toplevel :load-toplevel :execute)
 581   (defclass gtype (alien-object)
 582     ()
 583     (:metaclass alien-class)
 584     (:size 4 #|(size-of 'pointer)|#)))
 585
 586
 587 (defun %alien-instance-type-number (location)
 588   (let ((class (sap-ref-sap location 0)))
 589     (sap-ref-unsigned class 0)))
 590
 591
 592 (deftype-method translate-from-alien gtype (type-spec location &optional alloc)
 593   (declare (ignore type-spec alloc))
 594   `(let ((location ,location))
 595      (unless (null-pointer-p location)
 596        (ensure-alien-instance
 597         (type-from-number (%alien-instance-type-number location))
 598         location))))
 599
 600
 601
 602 ;;;; Metaclass for subclasses of gtype-class
 603
 604 (eval-when (:compile-toplevel :load-toplevel :execute)
 605   (defclass gtype-class (alien-class)))
 606
 607
 608 (defmethod shared-initialize ((class gtype-class) names
 609                               &rest initargs &key name)
 610   (declare (ignore initargs names))
 611   (call-next-method)
 612   (setf
 613    (slot-value class 'size)
 614    (type-instance-size (find-type-number (or name (class-name class))))))
 615
 616
 617 (defmethod validate-superclass
 618     ((class gtype-class) (super pcl::standard-class))
 619   (subtypep (class-name super) 'gtype))
 620
 621
 622 (defmethod allocate-alien-storage ((class gtype-class))
 623   (type-create-instance (find-type-number class)))
 624
 625
 626 ;;;; Initializing type numbers
 627
 628 (setf (alien-type-name 'invalid) "invalid")
 629 (setf (alien-type-name 'char) "gchar")
 630 (setf (alien-type-name 'unsigned-char) "guchar")
 631 (setf (alien-type-name 'boolean) "gboolean")
 632 (setf (alien-type-name 'int) "gint")
 633 (setf (alien-type-name 'unsigned-int) "guint")
 634 (setf (alien-type-name 'long) "glong")
 635 (setf (alien-type-name 'unsigned-long) "gulong")
 636 (setf (alien-type-name 'enum) "GEnum")
 637 (setf (alien-type-name 'flags) "GFlags")
 638 (setf (alien-type-name 'single-float) "gfloat")
 639 (setf (alien-type-name 'double-float) "gdouble")
 640 (setf (alien-type-name 'string) "gstring")
 641 (setf (find-type-number 'fixnum) (find-type-number 'int))