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