mdw@git.distorted.org.uk Git - clg/blob - glib/gtype.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2000-2006 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: gtype.lisp,v 1.55 2006-08-25 10:37:33 espen Exp $
  24
  25 (in-package "GLIB")
  26
  27 (use-prefix "g")
  28
  29 ;; Initialize the glib type system
  30 (defbinding type-init () nil)
  31 (type-init)
  32
  33 (deftype type-number () 'unsigned-long)
  34
  35 (deftype gtype () 'symbol)
  36
  37 (define-type-method alien-type ((type gtype))
  38   (declare (ignore type))
  39   (alien-type 'type-number))
  40
  41 (define-type-method size-of ((type gtype) &key (inlined t))
  42   (assert-inlined type inlined)
  43   (size-of 'type-number))
  44
  45 (define-type-method to-alien-form ((type gtype) gtype &optional copy-p)
  46   (declare (ignore type copy-p))
  47   `(find-type-number ,gtype t))
  48
  49 (define-type-method to-alien-function ((type gtype) &optional copy-p)
  50   (declare (ignore type copy-p))
  51   #'(lambda (gtype)
  52       (find-type-number gtype t)))
  53
  54 (define-type-method from-alien-form ((type gtype) form &key ref)
  55   (declare (ignore type ref))
  56   `(type-from-number ,form))
  57
  58 (define-type-method from-alien-function ((type gtype) &key ref)
  59   (declare (ignore type ref))
  60   #'(lambda (type-number)
  61       (type-from-number type-number)))
  62
  63 (define-type-method writer-function ((type gtype) &key temp (inlined t))
  64   (declare (ignore temp))
  65   (assert-inlined type inlined)
  66   (let ((writer (writer-function 'type-number)))
  67     #'(lambda (gtype location &optional (offset 0))
  68         (funcall writer (find-type-number gtype t) location offset))))
  69
  70 (define-type-method reader-function ((type gtype) &key ref (inlined t))
  71   (declare (ignore ref))
  72   (assert-inlined type inlined)
  73   (let ((reader (reader-function 'type-number)))
  74     #'(lambda (location &optional (offset 0))
  75         (type-from-number (funcall reader location offset)))))
  76
  77
  78 (eval-when (:compile-toplevel :load-toplevel :execute)
  79   (defclass type-query (struct)
  80     ((type-number :allocation :alien :type type-number)
  81      (name :allocation :alien :type (copy-of string))
  82      (class-size :allocation :alien :type unsigned-int)
  83      (instance-size :allocation :alien :type unsigned-int))
  84     (:metaclass struct-class)))
  85
  86
  87 (defbinding type-query (type) nil
  88   ((find-type-number type t) type-number)
  89   ((make-instance 'type-query) type-query :in/return))
  90
  91 (defun type-instance-size (type)
  92   (slot-value (type-query type) 'instance-size))
  93
  94 (defun type-class-size (type)
  95   (slot-value (type-query type) 'class-size))
  96
  97 (defbinding type-class-ref (type) pointer
  98   ((find-type-number type t) type-number))
  99
 100 (defbinding type-class-unref () nil
 101   (class pointer))
 102
 103 (defbinding type-class-peek (type) pointer
 104   ((find-type-number type t) type-number))
 105
 106
 107
 108 ;;;; Mapping between lisp types and glib types
 109
 110 (defvar *registered-types* ())
 111 (defvar *registered-type-aliases* ())
 112 (defvar *registered-static-types* ())
 113 (defvar *lisp-type-to-type-number* (make-hash-table))
 114 (defvar *type-number-to-lisp-type* (make-hash-table))
 115
 116 (defbinding %type-from-name () type-number
 117   (name string))
 118
 119 (defun type-number-from-glib-name (name &optional (error-p t))
 120   (let ((type-number (%type-from-name name)))
 121     (cond
 122      ((not (zerop type-number)) type-number)
 123      (error-p (error "Invalid gtype name: ~A" name)))))
 124
 125 (defun type-from-glib-name (name)
 126   (type-from-number (type-number-from-glib-name name) t))
 127
 128 (defun register-type (type id)
 129   (cond
 130    ((find-type-number type))
 131    ((not id) (warn "Can't register type with no foreign id: ~A" type))
 132    (t
 133     (pushnew (cons type id) *registered-types* :key #'car)
 134     (let ((type-number
 135            (typecase id
 136              (string (type-number-from-glib-name id))
 137              (symbol (funcall id)))))
 138       (setf (gethash type *lisp-type-to-type-number*) type-number)
 139       (setf (gethash type-number *type-number-to-lisp-type*) type)
 140       type-number))))
 141
 142 (defun register-type-alias (type alias)
 143   (pushnew (cons type alias) *registered-type-aliases* :key #'car)
 144   (setf
 145    (gethash type *lisp-type-to-type-number*)
 146    (find-type-number alias t)))
 147
 148 (defun reinitialize-all-types ()
 149   (clrhash *lisp-type-to-type-number*)
 150   (clrhash *type-number-to-lisp-type*)
 151   (type-init) ; initialize the glib type system
 152   (mapc #'(lambda (type)
 153             (register-type (car type) (cdr type)))
 154         *registered-types*)
 155   (mapc #'(lambda (type)
 156             (apply #'register-new-type type))
 157         (reverse *registered-static-types*))
 158   (mapc #'(lambda (type)
 159             (register-type-alias (car type) (cdr type)))
 160         *registered-type-aliases*))
 161
 162 (pushnew 'reinitialize-all-types
 163   #+cmu *after-save-initializations*
 164   #+sbcl *init-hooks*
 165   #+clisp custom:*init-hooks*)
 166
 167 #+cmu
 168 (pushnew 'system::reinitialize-global-table ; we shouldn't have to do this?
 169  *after-save-initializations*)
 170
 171
 172 (defun find-type-number (type &optional error-p)
 173   (etypecase type
 174     (integer type)
 175     (string (type-number-from-glib-name type error-p))
 176     (symbol
 177      (or
 178       (gethash type *lisp-type-to-type-number*)
 179       (and error-p (error "Type not registered: ~A" type))))
 180     (class (find-type-number (class-name type) error-p))))
 181
 182 (defun type-from-number (type-number &optional error)
 183   (multiple-value-bind (type found)
 184       (gethash type-number *type-number-to-lisp-type*)
 185     (if found
 186         type
 187       (let ((name (find-foreign-type-name type-number)))
 188         (cond
 189          ((and name (not (= (type-number-from-glib-name name nil) type-number)))
 190           ;; This is a hack because GdkEvent seems to be registered
 191           ;; multiple times
 192           (type-from-number (type-number-from-glib-name name)))
 193          ((and error name)
 194           (error "Type number not registered: ~A (~A)" type-number name))
 195          ((and error)
 196           (error "Invalid type number: ~A" type-number)))))))
 197
 198 (defbinding (find-foreign-type-name "g_type_name") (type) (copy-of string)
 199   ((find-type-number type t) type-number))
 200
 201 (defun type-number-of (object)
 202   (find-type-number (type-of object) t))
 203
 204 (eval-when (:compile-toplevel :load-toplevel :execute)
 205   (defvar *type-initializers* ())
 206   (defun %find-types-in-library (pathname prefixes ignore)
 207     (let ((process
 208            (run-program
 209             "/usr/bin/nm"
 210             #+clisp :arguments
 211             (list "--defined-only" "-D" (namestring (truename pathname)))
 212             :output :stream :wait nil)))
 213       (unwind-protect
 214           (loop
 215            as symbol = (let ((line (read-line
 216                                     #+(or cmu sbcl)
 217                                     (process-output process)
 218                                     #+clisp process
 219                                     nil)))
 220                          (when line
 221                            (subseq line (1+ (position #\Space line :from-end t)))))
 222            while symbol
 223            when (and
 224                  (> (length symbol) 9)
 225                  (or
 226                   (not prefixes)
 227                   (some #'(lambda (prefix)
 228                             (and
 229                              (> (length symbol) (length prefix))
 230                              (string= prefix symbol :end2 (length prefix))))
 231                         (mklist prefixes)))
 232                  (string= "_get_type" symbol :start2 (- (length symbol) 9))
 233                  (not (member symbol ignore :test #'string=)))
 234            collect symbol)
 235         (#+(or cmu sbcl)process-close
 236          #+clisp close
 237          process)))))
 238
 239
 240 (defmacro init-types-in-library (filename &key prefix ignore)
 241   (let ((names (%find-types-in-library filename prefix ignore)))
 242     `(progn
 243        ,@(mapcar #'(lambda (name)
 244                      `(progn
 245                         (defbinding (,(intern name) ,name) () type-number)
 246                         (,(intern name))
 247                         (pushnew ',(intern name) *type-initializers*)))
 248                  names))))
 249
 250 (defun find-type-init-function (type-number)
 251   (loop
 252    for type-init in *type-initializers*
 253    when (= type-number (funcall type-init))
 254    do (return type-init)))
 255
 256 (defun register-type-as (type-number)
 257   (or
 258    (find-type-init-function type-number)
 259    (find-foreign-type-name type-number)
 260    (error "Unknown type-number: ~A" type-number)))
 261
 262 (defun default-type-init-name (type)
 263   (find-symbol (format nil "~A_~A_get_type"
 264                 (package-prefix *package*)
 265                 (substitute #\_ #\- (string-downcase type)))))
 266
 267
 268 (eval-when (:compile-toplevel :load-toplevel :execute)
 269   (defclass type-info (struct)
 270     ((class-size :allocation :alien :type (unsigned 16) :initarg :class-size)
 271      (base-init :allocation :alien :type pointer)
 272      (base-finalize :allocation :alien :type pointer)
 273      (class-init :allocation :alien :type pointer)
 274      (class-finalize :allocation :alien :type pointer)
 275      (class-data :allocation :alien :type pointer)
 276      (instance-size :allocation :alien :type (unsigned 16)
 277                     :initarg :instance-size)
 278      (n-preallocs :allocation :alien :type (unsigned 16))
 279      (instance-init :allocation :alien :type pointer)
 280      (value-table :allocation :alien :type pointer))
 281     (:metaclass struct-class)))
 282
 283 (defbinding %type-register-static () type-number
 284   (parent-type type-number)
 285   (name string)
 286   (info type-info)
 287   (0 unsigned-int))
 288
 289 (defun register-new-type (type parent &optional foreign-name)
 290   (let ((parent-info (type-query parent)))
 291     (with-slots ((parent-number type-number) class-size instance-size) parent-info
 292       (let ((type-number
 293              (%type-register-static
 294               parent-number
 295               (or foreign-name (default-alien-type-name type))
 296               (make-instance 'type-info :class-size class-size :instance-size instance-size))))
 297         (pushnew (list type parent foreign-name) *registered-static-types* :key #'car)
 298         (setf (gethash type *lisp-type-to-type-number*) type-number)
 299         (setf (gethash type-number *type-number-to-lisp-type*) type)
 300         type-number))))
 301
 302
 303
 304 ;;;; Metaclass for subclasses of ginstance
 305
 306 (eval-when (:compile-toplevel :load-toplevel :execute)
 307   (defclass ginstance-class (proxy-class)
 308     ((gtype :initarg :gtype :initform nil :reader ginstance-class-gtype))))
 309
 310
 311 (defun update-size (class)
 312   (let ((type-number (find-type-number class)))
 313     (cond
 314      ((not (foreign-size-p class))
 315       (setf (foreign-size class) (type-instance-size type-number)))
 316      ((and
 317        (foreign-size-p class)
 318        (not (= (type-instance-size type-number) (foreign-size class))))
 319       (warn "Size mismatch for class ~A" class)))))
 320
 321
 322 (defmethod finalize-inheritance ((class ginstance-class))
 323   (prog1
 324       #+clisp(call-next-method)
 325     (let* ((class-name (class-name class))
 326            (super (most-specific-proxy-superclass class))
 327            (gtype (or
 328                    (first (ginstance-class-gtype class))
 329                    (default-alien-type-name class-name)))
 330            (type-number
 331             (or
 332              (find-type-number class-name)
 333              (let ((type-number
 334                     (if (or
 335                          (symbolp gtype)
 336                          (type-number-from-glib-name gtype nil))
 337                         (register-type class-name gtype)
 338                       (register-new-type class-name (class-name super) gtype))))
 339                (type-class-ref type-number)
 340                type-number))))
 341       #+nil
 342       (when (and
 343              (supertype type-number)
 344              (not (eq (class-name super) (supertype type-number))))
 345         (warn "Super class mismatch between CLOS and GObject for ~A"
 346               class-name)))
 347     (update-size class))
 348   #-clisp(call-next-method))
 349
 350
 351 (defmethod shared-initialize ((class ginstance-class) names &rest initargs)
 352   (declare (ignore names initargs))
 353   (call-next-method)
 354   (when (class-finalized-p class)
 355     (update-size class)))
 356
 357
 358 (defmethod validate-superclass ((class ginstance-class) (super standard-class))
 359   (subtypep (class-name super) 'ginstance))
 360
 361
 362 ;;;; Superclass for wrapping types in the glib type system
 363
 364 (eval-when (:compile-toplevel :load-toplevel :execute)
 365   (defclass ginstance (proxy)
 366     (;(class :allocation :alien :type pointer :offset 0)
 367      )
 368     (:metaclass proxy-class)
 369     (:size #.(size-of 'pointer))))
 370
 371 (defun ref-type-number (location &optional offset)
 372   (declare (ignore location offset)))
 373
 374 (setf (symbol-function 'ref-type-number) (reader-function 'type-number))
 375
 376 (defun %type-number-of-ginstance (location)
 377   (let ((class (ref-pointer location)))
 378     (ref-type-number class)))
 379
 380 (defmethod make-proxy-instance :around ((class ginstance-class) location
 381                                         &rest initargs)
 382   (declare (ignore class))
 383   (let ((class (labels ((find-known-class (type-number)
 384                           (or
 385                            (find-class (type-from-number type-number) nil)
 386                            (unless (zerop type-number)
 387                              (find-known-class (type-parent type-number))))))
 388                  (find-known-class (%type-number-of-ginstance location)))))
 389     ;; Note that chancing the class argument should not alter "the
 390     ;; ordered set of applicable methods" as specified in the
 391     ;; Hyperspec
 392     (if class
 393         (apply #'call-next-method class location initargs)
 394       (error "Object at ~A has an unkown type number: ~A"
 395        location (%type-number-of-ginstance location)))))
 396
 397 (define-type-method from-alien-form ((type ginstance) form &key (ref :copy))
 398   (call-next-method type form :ref ref))
 399
 400 (define-type-method from-alien-function ((type ginstance) &key (ref :copy))
 401   (call-next-method type :ref ref))
 402
 403
 404 ;;;; Registering fundamental types
 405
 406 (register-type 'nil "void")
 407 (register-type 'pointer "gpointer")
 408 (register-type 'char "gchar")
 409 (register-type 'unsigned-char "guchar")
 410 (register-type 'boolean "gboolean")
 411 (register-type 'int "gint")
 412 (register-type-alias 'integer 'int)
 413 (register-type-alias 'fixnum 'int)
 414 (register-type 'unsigned-int "guint")
 415 (register-type 'long "glong")
 416 (register-type 'unsigned-long "gulong")
 417 (register-type 'single-float "gfloat")
 418 (register-type 'double-float "gdouble")
 419 (register-type 'pathname "gchararray")
 420 (register-type 'string "gchararray")
 421
 422
 423 ;;;; Introspection of type information
 424
 425 (defvar *derivable-type-info* (make-hash-table))
 426
 427 (defun register-derivable-type (type id expander &optional dependencies)
 428   (register-type type id)
 429   (let ((type-number (register-type type id)))
 430     (setf
 431      (gethash type-number *derivable-type-info*)
 432      (list expander dependencies))))
 433
 434 (defun find-type-info (type)
 435   (dolist (super (cdr (type-hierarchy type)))
 436     (let ((info (gethash super *derivable-type-info*)))
 437       (return-if info))))
 438
 439 (defun expand-type-definition (type forward-p options)
 440   (let ((expander (first (find-type-info type))))
 441     (funcall expander (find-type-number type t) forward-p options)))
 442
 443
 444 (defbinding type-parent (type) type-number
 445   ((find-type-number type t) type-number))
 446
 447 (defun supertype (type)
 448   (type-from-number (type-parent type)))
 449
 450 (defbinding %type-interfaces (type) pointer
 451   ((find-type-number type t) type-number)
 452   (n-interfaces unsigned-int :out))
 453
 454 (defun type-interfaces (type)
 455   (multiple-value-bind (array length) (%type-interfaces type)
 456     (unwind-protect
 457         (map-c-vector 'list #'identity array 'type-number length)
 458       (deallocate-memory array))))
 459
 460 (defun implements (type)
 461   (mapcar #'type-from-number (type-interfaces type)))
 462
 463 (defun type-hierarchy (type)
 464   (let ((type-number (find-type-number type t)))
 465     (unless (= type-number 0)
 466       (cons type-number (type-hierarchy (type-parent type-number))))))
 467
 468 (defbinding (type-is-p "g_type_is_a") (type super) boolean
 469   ((find-type-number type) type-number)
 470   ((find-type-number super) type-number))
 471
 472 (defbinding %type-children () pointer
 473   (type-number type-number)
 474   (num-children unsigned-int :out))
 475
 476 (defun map-subtypes (function type &optional prefix)
 477   (let ((type-number (find-type-number type t)))
 478     (multiple-value-bind (array length) (%type-children type-number)
 479       (unwind-protect
 480           (map-c-vector
 481            'nil
 482            #'(lambda (type-number)
 483                (when (or
 484                       (not prefix)
 485                       (string-prefix-p prefix (find-foreign-type-name type-number)))
 486                  (funcall function type-number))
 487                (map-subtypes function type-number prefix))
 488            array 'type-number length)
 489         (deallocate-memory array)))))
 490
 491 (defun find-types (prefix)
 492   (let ((type-list nil))
 493     (maphash
 494      #'(lambda (type-number expander)
 495          (declare (ignore expander))
 496          (map-subtypes
 497           #'(lambda (type-number)
 498               (pushnew type-number type-list))
 499           type-number prefix))
 500      *derivable-type-info*)
 501     type-list))
 502
 503 (defun find-type-dependencies (type &optional options)
 504   (let ((find-dependencies (second (find-type-info type))))
 505     (when find-dependencies
 506       (remove-duplicates
 507        (mapcar #'find-type-number
 508         (funcall find-dependencies (find-type-number type t) options))))))
 509
 510
 511 ;; The argument is a list where each elements is on the form
 512 ;; (type . dependencies). This function will not handle indirect
 513 ;; dependencies and types depending on them selve.
 514 (defun sort-types-topologicaly (unsorted)
 515   (flet ((depend-p (type1)
 516            (find-if #'(lambda (type2)
 517                         (and
 518                          ;; If a type depends a subtype it has to be
 519                          ;; forward defined
 520                          (not (type-is-p (car type2) (car type1)))
 521                          (find (car type2) (cdr type1))))
 522                     unsorted)))
 523     (let ((sorted
 524            (loop
 525             while unsorted
 526             nconc (multiple-value-bind (sorted remaining)
 527                       (delete-collect-if
 528                        #'(lambda (type)
 529                            (or (not (cdr type)) (not (depend-p type))))
 530                        unsorted)
 531                     (cond
 532                      ((not sorted)
 533                       ;; We have a circular dependency which have to
 534                       ;; be resolved
 535                       (let ((selected
 536                              (find-if
 537                               #'(lambda (type)
 538                                   (every
 539                                    #'(lambda (dep)
 540                                        (or
 541                                         (not (type-is-p (car type) dep))
 542                                         (not (find dep unsorted :key #'car))))
 543                                    (cdr type)))
 544                               unsorted)))
 545                         (unless selected
 546                           (error "Couldn't resolve circular dependency"))
 547                         (setq unsorted (delete selected unsorted))
 548                         (list selected)))
 549                      (t
 550                       (setq unsorted remaining)
 551                       sorted))))))
 552
 553       ;; Mark types which have to be forward defined
 554       (loop
 555        for tmp on sorted
 556        as (type . dependencies) = (first tmp)
 557        collect (cons type (and
 558                            dependencies
 559                            (find-if #'(lambda (type)
 560                                         (find (car type) dependencies))
 561                                     (rest tmp))
 562                            t))))))
 563
 564
 565 (defun expand-type-definitions (prefix &optional args)
 566   (flet ((type-options (type-number)
 567            (let ((name (find-foreign-type-name type-number)))
 568              (cdr (assoc name args :test #'string=)))))
 569
 570    (let ((type-list
 571           (delete-if
 572            #'(lambda (type-number)
 573                (let ((name (find-foreign-type-name type-number)))
 574                  (or
 575                   (getf (type-options type-number) :ignore)
 576                   (find-if
 577                    #'(lambda (options)
 578                        (and
 579                         (string-prefix-p (first options) name)
 580                         (getf (cdr options) :ignore-prefix)
 581                         (not (some
 582                               #'(lambda (exception)
 583                                   (string= name exception))
 584                               (getf (cdr options) :except)))))
 585                    args))))
 586            (find-types prefix))))
 587
 588      (dolist (type-number type-list)
 589        (let ((name (find-foreign-type-name type-number)))
 590          (register-type
 591           (getf (type-options type-number) :type (default-type-name name))
 592           (register-type-as type-number))))
 593
 594      ;; This is needed for some unknown reason to get type numbers right
 595      (mapc #'find-type-dependencies type-list)
 596
 597      (let ((sorted-type-list
 598             #+clisp (mapcar #'list type-list)
 599             #-clisp
 600             (sort-types-topologicaly
 601              (mapcar
 602               #'(lambda (type)
 603                   (cons type (find-type-dependencies type (type-options type))))
 604               type-list))))
 605        `(progn
 606           ,@(mapcar
 607              #'(lambda (pair)
 608                  (destructuring-bind (type . forward-p) pair
 609                    (expand-type-definition type forward-p (type-options type))))
 610              sorted-type-list)
 611           ,@(mapcar
 612              #'(lambda (pair)
 613                  (destructuring-bind (type . forward-p) pair
 614                    (when forward-p
 615                      (expand-type-definition type nil (type-options type)))))
 616              sorted-type-list))))))
 617
 618 (defmacro define-types-by-introspection (prefix &rest args)
 619   (expand-type-definitions prefix args))
 620
 621 (defexport define-types-by-introspection (prefix &rest args)
 622   (list-autoexported-symbols (expand-type-definitions prefix args)))
 623
 624
 625 ;;;; Initialize all non static types in GObject
 626
 627 (init-types-in-library #.(concatenate 'string (pkg-config:pkg-variable "glib-2.0" "libdir") "/libgobject-2.0.so"))