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