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.54 2006-08-16 11:02:46 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       #+nil
 339       (when (and
 340              (supertype type-number)
 341              (not (eq (class-name super) (supertype type-number))))
 342         (warn "Super class mismatch between CLOS and GObject for ~A"
 343               class-name)))
 344     (update-size class))
 345   #-clisp(call-next-method))
 346
 347
 348 (defmethod shared-initialize ((class ginstance-class) names &rest initargs)
 349   (declare (ignore names initargs))
 350   (call-next-method)
 351   (when (class-finalized-p class)
 352     (update-size class)))
 353
 354
 355 (defmethod validate-superclass ((class ginstance-class) (super standard-class))
 356   (subtypep (class-name super) 'ginstance))
 357
 358
 359 ;;;; Superclass for wrapping types in the glib type system
 360
 361 (eval-when (:compile-toplevel :load-toplevel :execute)
 362   (defclass ginstance (proxy)
 363     (;(class :allocation :alien :type pointer :offset 0)
 364      )
 365     (:metaclass proxy-class)
 366     (:size #.(size-of 'pointer))))
 367
 368 (defun ref-type-number (location &optional offset)
 369   (declare (ignore location offset)))
 370
 371 (setf (symbol-function 'ref-type-number) (reader-function 'type-number))
 372
 373 (defun %type-number-of-ginstance (location)
 374   (let ((class (ref-pointer location)))
 375     (ref-type-number class)))
 376
 377 (defmethod make-proxy-instance :around ((class ginstance-class) location
 378                                         &rest initargs)
 379   (declare (ignore class))
 380   (let ((class (labels ((find-known-class (type-number)
 381                           (or
 382                            (find-class (type-from-number type-number) nil)
 383                            (unless (zerop type-number)
 384                              (find-known-class (type-parent type-number))))))
 385                  (find-known-class (%type-number-of-ginstance location)))))
 386     ;; Note that chancing the class argument should not alter "the
 387     ;; ordered set of applicable methods" as specified in the
 388     ;; Hyperspec
 389     (if class
 390         (apply #'call-next-method class location initargs)
 391       (error "Object at ~A has an unkown type number: ~A"
 392        location (%type-number-of-ginstance location)))))
 393
 394 (define-type-method from-alien-form ((type ginstance) form &key (ref :copy))
 395   (call-next-method type form :ref ref))
 396
 397 (define-type-method from-alien-function ((type ginstance) &key (ref :copy))
 398   (call-next-method type :ref ref))
 399
 400
 401 ;;;; Registering fundamental types
 402
 403 (register-type 'nil "void")
 404 (register-type 'pointer "gpointer")
 405 (register-type 'char "gchar")
 406 (register-type 'unsigned-char "guchar")
 407 (register-type 'boolean "gboolean")
 408 (register-type 'int "gint")
 409 (register-type-alias 'integer 'int)
 410 (register-type-alias 'fixnum 'int)
 411 (register-type 'unsigned-int "guint")
 412 (register-type 'long "glong")
 413 (register-type 'unsigned-long "gulong")
 414 (register-type 'single-float "gfloat")
 415 (register-type 'double-float "gdouble")
 416 (register-type 'pathname "gchararray")
 417 (register-type 'string "gchararray")
 418
 419
 420 ;;;; Introspection of type information
 421
 422 (defvar *derivable-type-info* (make-hash-table))
 423
 424 (defun register-derivable-type (type id expander &optional dependencies)
 425   (register-type type id)
 426   (let ((type-number (register-type type id)))
 427     (setf
 428      (gethash type-number *derivable-type-info*)
 429      (list expander dependencies))))
 430
 431 (defun find-type-info (type)
 432   (dolist (super (cdr (type-hierarchy type)))
 433     (let ((info (gethash super *derivable-type-info*)))
 434       (return-if info))))
 435
 436 (defun expand-type-definition (type forward-p options)
 437   (let ((expander (first (find-type-info type))))
 438     (funcall expander (find-type-number type t) forward-p options)))
 439
 440
 441 (defbinding type-parent (type) type-number
 442   ((find-type-number type t) type-number))
 443
 444 (defun supertype (type)
 445   (type-from-number (type-parent type)))
 446
 447 (defbinding %type-interfaces (type) pointer
 448   ((find-type-number type t) type-number)
 449   (n-interfaces unsigned-int :out))
 450
 451 (defun type-interfaces (type)
 452   (multiple-value-bind (array length) (%type-interfaces type)
 453     (unwind-protect
 454         (map-c-vector 'list #'identity array 'type-number length)
 455       (deallocate-memory array))))
 456
 457 (defun implements (type)
 458   (mapcar #'type-from-number (type-interfaces type)))
 459
 460 (defun type-hierarchy (type)
 461   (let ((type-number (find-type-number type t)))
 462     (unless (= type-number 0)
 463       (cons type-number (type-hierarchy (type-parent type-number))))))
 464
 465 (defbinding (type-is-p "g_type_is_a") (type super) boolean
 466   ((find-type-number type) type-number)
 467   ((find-type-number super) type-number))
 468
 469 (defbinding %type-children () pointer
 470   (type-number type-number)
 471   (num-children unsigned-int :out))
 472
 473 (defun map-subtypes (function type &optional prefix)
 474   (let ((type-number (find-type-number type t)))
 475     (multiple-value-bind (array length) (%type-children type-number)
 476       (unwind-protect
 477           (map-c-vector
 478            'nil
 479            #'(lambda (type-number)
 480                (when (or
 481                       (not prefix)
 482                       (string-prefix-p prefix (find-foreign-type-name type-number)))
 483                  (funcall function type-number))
 484                (map-subtypes function type-number prefix))
 485            array 'type-number length)
 486         (deallocate-memory array)))))
 487
 488 (defun find-types (prefix)
 489   (let ((type-list nil))
 490     (maphash
 491      #'(lambda (type-number expander)
 492          (declare (ignore expander))
 493          (map-subtypes
 494           #'(lambda (type-number)
 495               (pushnew type-number type-list))
 496           type-number prefix))
 497      *derivable-type-info*)
 498     type-list))
 499
 500 (defun find-type-dependencies (type &optional options)
 501   (let ((find-dependencies (second (find-type-info type))))
 502     (when find-dependencies
 503       (remove-duplicates
 504        (mapcar #'find-type-number
 505         (funcall find-dependencies (find-type-number type t) options))))))
 506
 507
 508 ;; The argument is a list where each elements is on the form
 509 ;; (type . dependencies). This function will not handle indirect
 510 ;; dependencies and types depending on them selve.
 511 (defun sort-types-topologicaly (unsorted)
 512   (flet ((depend-p (type1)
 513            (find-if #'(lambda (type2)
 514                         (and
 515                          ;; If a type depends a subtype it has to be
 516                          ;; forward defined
 517                          (not (type-is-p (car type2) (car type1)))
 518                          (find (car type2) (cdr type1))))
 519                     unsorted)))
 520     (let ((sorted
 521            (loop
 522             while unsorted
 523             nconc (multiple-value-bind (sorted remaining)
 524                       (delete-collect-if
 525                        #'(lambda (type)
 526                            (or (not (cdr type)) (not (depend-p type))))
 527                        unsorted)
 528                     (cond
 529                      ((not sorted)
 530                       ;; We have a circular dependency which have to
 531                       ;; be resolved
 532                       (let ((selected
 533                              (find-if
 534                               #'(lambda (type)
 535                                   (every
 536                                    #'(lambda (dep)
 537                                        (or
 538                                         (not (type-is-p (car type) dep))
 539                                         (not (find dep unsorted :key #'car))))
 540                                    (cdr type)))
 541                               unsorted)))
 542                         (unless selected
 543                           (error "Couldn't resolve circular dependency"))
 544                         (setq unsorted (delete selected unsorted))
 545                         (list selected)))
 546                      (t
 547                       (setq unsorted remaining)
 548                       sorted))))))
 549
 550       ;; Mark types which have to be forward defined
 551       (loop
 552        for tmp on sorted
 553        as (type . dependencies) = (first tmp)
 554        collect (cons type (and
 555                            dependencies
 556                            (find-if #'(lambda (type)
 557                                         (find (car type) dependencies))
 558                                     (rest tmp))
 559                            t))))))
 560
 561
 562 (defun expand-type-definitions (prefix &optional args)
 563   (flet ((type-options (type-number)
 564            (let ((name (find-foreign-type-name type-number)))
 565              (cdr (assoc name args :test #'string=)))))
 566
 567    (let ((type-list
 568           (delete-if
 569            #'(lambda (type-number)
 570                (let ((name (find-foreign-type-name type-number)))
 571                  (or
 572                   (getf (type-options type-number) :ignore)
 573                   (find-if
 574                    #'(lambda (options)
 575                        (and
 576                         (string-prefix-p (first options) name)
 577                         (getf (cdr options) :ignore-prefix)
 578                         (not (some
 579                               #'(lambda (exception)
 580                                   (string= name exception))
 581                               (getf (cdr options) :except)))))
 582                    args))))
 583            (find-types prefix))))
 584
 585      (dolist (type-number type-list)
 586        (let ((name (find-foreign-type-name type-number)))
 587          (register-type
 588           (getf (type-options type-number) :type (default-type-name name))
 589           (register-type-as type-number))))
 590
 591      ;; This is needed for some unknown reason to get type numbers right
 592      (mapc #'find-type-dependencies type-list)
 593
 594      (let ((sorted-type-list
 595             #+clisp (mapcar #'list type-list)
 596             #-clisp
 597             (sort-types-topologicaly
 598              (mapcar
 599               #'(lambda (type)
 600                   (cons type (find-type-dependencies type (type-options type))))
 601               type-list))))
 602        `(progn
 603           ,@(mapcar
 604              #'(lambda (pair)
 605                  (destructuring-bind (type . forward-p) pair
 606                    (expand-type-definition type forward-p (type-options type))))
 607              sorted-type-list)
 608           ,@(mapcar
 609              #'(lambda (pair)
 610                  (destructuring-bind (type . forward-p) pair
 611                    (when forward-p
 612                      (expand-type-definition type nil (type-options type)))))
 613              sorted-type-list))))))
 614
 615 (defmacro define-types-by-introspection (prefix &rest args)
 616   (expand-type-definitions prefix args))
 617
 618 (defexport define-types-by-introspection (prefix &rest args)
 619   (list-autoexported-symbols (expand-type-definitions prefix args)))
 620
 621
 622 ;;;; Initialize all non static types in GObject
 623
 624 (init-types-in-library #.(concatenate 'string (pkg-config:pkg-variable "glib-2.0" "libdir") "/libgobject-2.0.so"))