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