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