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