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