chiark / gitweb /
Added bindigns to GdkAtom
[clg] / glib / gtype.lisp
CommitLineData
560af5c5 1;; Common Lisp bindings for GTK+ v2.0
d4b21b08 2;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
560af5c5 3;;
4;; This library is free software; you can redistribute it and/or
5;; modify it under the terms of the GNU Lesser General Public
6;; License as published by the Free Software Foundation; either
7;; version 2 of the License, or (at your option) any later version.
8;;
9;; This library is distributed in the hope that it will be useful,
10;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12;; Lesser General Public License for more details.
13;;
14;; You should have received a copy of the GNU Lesser General Public
15;; License along with this library; if not, write to the Free Software
16;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17
63752532 18;; $Id: gtype.lisp,v 1.23 2005-01-12 13:33:06 espen Exp $
560af5c5 19
20(in-package "GLIB")
21
22(use-prefix "g")
23
e0349dbd 24;; Initialize the glib type system
25(defbinding type-init () nil)
26(type-init)
560af5c5 27
28(deftype type-number () '(unsigned 32))
29
e74cfcab 30(deftype gtype () 'symbol)
31
32(defmethod alien-type ((type (eql 'gtype)) &rest args)
33 (declare (ignore type args))
34 (alien-type 'type-number))
35
36(defmethod size-of ((type (eql 'gtype)) &rest args)
37 (declare (ignore type args))
38 (size-of 'type-number))
39
40(defmethod to-alien-form (gtype (type (eql 'gtype)) &rest args)
41 (declare (ignore type args))
42 `(find-type-number ,gtype t))
43
44(defmethod to-alien-function ((type (eql 'gtype)) &rest args)
45 (declare (ignore type args))
46 #'(lambda (gtype)
47 (find-type-number gtype t)))
48
49(defmethod from-alien-form (type-number (type (eql 'gtype)) &rest args)
50 (declare (ignore type args))
63752532 51 `(type-from-number ,type-number))
e74cfcab 52
53(defmethod from-alien-function ((type (eql 'gtype)) &rest args)
54 (declare (ignore type args))
55 #'(lambda (type-number)
63752532 56 (type-from-number type-number)))
e74cfcab 57
58(defmethod writer-function ((type (eql 'gtype)) &rest args)
59 (declare (ignore type))
60 (let ((writer (writer-function 'type-number)))
61 #'(lambda (gtype location &optional (offset 0))
62 (funcall writer (find-type-number gtype t) location offset))))
63
64(defmethod reader-function ((type (eql 'gtype)) &rest args)
65 (declare (ignore type))
66 (let ((reader (reader-function 'type-number)))
67 #'(lambda (location &optional (offset 0))
63752532 68 (type-from-number (funcall reader location offset)))))
e74cfcab 69
70
93aa67db 71(eval-when (:compile-toplevel :load-toplevel :execute)
d4b21b08 72 (defclass type-query (struct)
93aa67db 73 ((type-number :allocation :alien :type type-number)
74 (name :allocation :alien :type string)
75 (class-size :allocation :alien :type unsigned-int)
76 (instance-size :allocation :alien :type unsigned-int))
d168bafd 77 (:metaclass struct-class)))
93aa67db 78
79
e74cfcab 80(defbinding type-query (type) nil
81 ((find-type-number type t) type-number)
82 ((make-instance 'type-query) type-query :return))
93aa67db 83
84(defun type-instance-size (type)
85 (slot-value (type-query type) 'instance-size))
86
87(defun type-class-size (type)
88 (slot-value (type-query type) 'class-size))
560af5c5 89
d4b21b08 90(defbinding type-class-ref (type) pointer
91 ((find-type-number type t) type-number))
560af5c5 92
d4b21b08 93(defbinding type-class-unref (type) nil
94 ((find-type-number type t) type-number))
93aa67db 95
d4b21b08 96(defbinding type-class-peek (type) pointer
97 ((find-type-number type t) type-number))
93aa67db 98
560af5c5 99
d4b21b08 100;;;; Mapping between lisp types and glib types
560af5c5 101
102(defvar *type-to-number-hash* (make-hash-table))
103(defvar *number-to-type-hash* (make-hash-table))
104
d4b21b08 105(defun register-type (type id)
106 (let ((type-number
107 (etypecase id
108 (integer id)
4d83a8a6 109 (string (find-type-number id t))
110 (symbol (gethash id *type-to-number-hash*)))))
d4b21b08 111 (setf (gethash type *type-to-number-hash*) type-number)
4d83a8a6 112 (unless (symbolp id)
113 (setf (gethash type-number *number-to-type-hash*) type))
d4b21b08 114 type-number))
115
116(defbinding %type-from-name () type-number
117 (name string))
118
119(defun find-type-number (type &optional error)
560af5c5 120 (etypecase type
121 (integer type)
d4b21b08 122 (string
123 (let ((type-number (%type-from-name type)))
124 (cond
125 ((and (zerop type-number) error)
d168bafd 126 (error "Invalid gtype name: ~A" type))
d4b21b08 127 ((zerop type-number) nil)
128 (t type-number))))
129 (symbol
130 (let ((type-number (gethash type *type-to-number-hash*)))
131 (or
132 type-number
133 (and error (error "Type not registered: ~A" type)))))
134 (pcl::class (find-type-number (class-name type) error))))
560af5c5 135
4de90d10 136(defun type-from-number (type-number &optional error)
137 (multiple-value-bind (type found)
138 (gethash type-number *number-to-type-hash*)
139 (when (and error (not found))
140 (let ((name (find-type-name type-number)))
141 (if name
142 (error "Type number not registered: ~A (~A)" type-number name)
143 (error "Invalid type number: ~A" type-number))))
144 type))
560af5c5 145
d4b21b08 146(defun type-from-name (name)
147 (etypecase name
148 (string (type-from-number (find-type-number name t)))))
560af5c5 149
9ca5565a 150(defbinding (find-type-name "g_type_name") (type) (copy-of string)
d4b21b08 151 ((find-type-number type t) type-number))
152
153(defun type-number-of (object)
154 (find-type-number (type-of object) t))
155
156(defun init-type (init)
157 (mapc
158 #'(lambda (fname)
159 (funcall (mkbinding fname 'type-number)))
160 (mklist init)))
161
d168bafd 162(defun %init-types-in-library (pathname prefix ignore)
d4b21b08 163 (let ((process (ext:run-program
0c0db5e2 164 "nm" (list "-D" (namestring (truename pathname)))
d4b21b08 165 :output :stream :wait nil))
166 (fnames ()))
167 (labels ((read-symbols ()
168 (let ((line (read-line (ext:process-output process) nil)))
169 (when line
4de90d10 170 (let ((symbol (subseq line 11)))
171 (when (and
d168bafd 172 (> (length symbol) (length prefix))
173 (string= prefix symbol :end2 (length prefix))
4de90d10 174 (search "_get_type" symbol)
175 (not (member symbol ignore :test #'string=)))
176 (push symbol fnames)))
d4b21b08 177 (read-symbols)))))
178 (read-symbols)
179 (ext:process-close process)
180 `(init-type ',fnames))))
560af5c5 181
d168bafd 182(defmacro init-types-in-library (filename &key (prefix "") ignore)
183 (%init-types-in-library filename prefix ignore))
4de90d10 184
185
560af5c5 186
93aa67db 187;;;; Superclass for wrapping types in the glib type system
560af5c5 188
189(eval-when (:compile-toplevel :load-toplevel :execute)
93aa67db 190 (defclass ginstance (proxy)
d4b21b08 191 ((class :allocation :alien :type pointer))
192 (:metaclass proxy-class)))
560af5c5 193
93aa67db 194(defun %type-of-ginstance (location)
195 (let ((class (sap-ref-sap location 0)))
d168bafd 196 (type-from-number (sap-ref-32 class 0))))
560af5c5 197
d168bafd 198(defmethod ensure-proxy-instance ((class ginstance-class) location)
199 (declare (ignore class))
200 (let ((class (find-class (%type-of-ginstance location))))
201 (if class
202 (make-instance class :location (reference-foreign class location))
203 ;; TODO: (make-instance 'ginstance ...)
204 location)))
560af5c5 205
9ca5565a 206(defmethod copy-from-alien-form (location (class ginstance-class) &rest args)
207 (declare (ignore location class args))
208 (error "Doing copy-from-alien on a ref. counted class is most certainly an error, but if it really is what you want you should use REFERENCE-FOREIGN on the returned instance instead."))
209
210(defmethod copy-from-alien-function ((class ginstance-class) &rest args)
211 (declare (ignore class args))
212 (error "Doing copy-from-alien on a ref. counted class is most certainly an error, but if it really is what you want you should use REFERENCE-FOREIGN on the returned instance instead."))
213
214(defmethod reader-function ((class ginstance-class) &rest args)
215 (declare (ignore args))
216 #'(lambda (location &optional (offset 0))
217 (ensure-proxy-instance class (sap-ref-sap location offset))))
218
560af5c5 219
93aa67db 220;;;; Metaclass for subclasses of ginstance
560af5c5 221
222(eval-when (:compile-toplevel :load-toplevel :execute)
4d83a8a6 223 (defclass ginstance-class (proxy-class)
224 ()))
560af5c5 225
226
c8c48a4c 227(defmethod shared-initialize ((class ginstance-class) names
d168bafd 228 &rest initargs &key name alien-name)
229 (declare (ignore names))
93aa67db 230 (let* ((class-name (or name (class-name class)))
231 (type-number
d4b21b08 232 (find-type-number
4de90d10 233 (or (first alien-name) (default-alien-type-name class-name)) t)))
d4b21b08 234 (register-type class-name type-number)
4d83a8a6 235 (if (getf initargs :size)
236 (call-next-method)
237 (let ((size (type-instance-size type-number)))
d168bafd 238 (apply #'call-next-method class names :size (list size) initargs)))))
239
240
241(defmethod validate-superclass ((class ginstance-class) (super standard-class))
c8c48a4c 242 (subtypep (class-name super) 'ginstance))
560af5c5 243
244
d4b21b08 245;;;; Registering fundamental types
246
63752532 247(register-type 'nil "void")
d4b21b08 248(register-type 'pointer "gpointer")
249(register-type 'char "gchar")
250(register-type 'unsigned-char "guchar")
251(register-type 'boolean "gboolean")
252(register-type 'fixnum "gint")
253(register-type 'int "gint")
254(register-type 'unsigned-int "guint")
255(register-type 'long "glong")
256(register-type 'unsigned-long "gulong")
257(register-type 'single-float "gfloat")
258(register-type 'double-float "gdouble")
a8cb9408 259(register-type 'pathname "gchararray")
4de90d10 260(register-type 'string "gchararray")
d4b21b08 261
262
263;;;;
264
e77e7713 265(defvar *derivable-type-info* (make-hash-table))
d4b21b08 266
e77e7713 267(defun register-derivable-type (type id expander)
d4b21b08 268 (register-type type id)
e77e7713 269 (let ((type-number (register-type type id)))
270 (setf (gethash type-number *derivable-type-info*) expander)))
d4b21b08 271
4de90d10 272(defun find-type-info (type)
273 (dolist (super (cdr (type-hierarchy type)))
e77e7713 274 (let ((info (gethash super *derivable-type-info*)))
4de90d10 275 (return-if info))))
276
e77e7713 277(defun expand-type-definition (type options)
278 (let ((expander (find-type-info type)))
279 (funcall expander (find-type-number type t) options)))
d4b21b08 280
d4b21b08 281(defbinding type-parent (type) type-number
282 ((find-type-number type t) type-number))
283
284(defun supertype (type)
285 (type-from-number (type-parent type)))
286
337933d8 287(defbinding %type-interfaces (type) pointer
288 ((find-type-number type t) type-number)
289 (n-interfaces unsigned-int :out))
290
291(defun type-interfaces (type)
292 (multiple-value-bind (array length) (%type-interfaces type)
293 (unwind-protect
d168bafd 294 (map-c-vector 'list #'identity array 'type-number length)
337933d8 295 (deallocate-memory array))))
296
297(defun implements (type)
298 (mapcar #'type-from-number (type-interfaces type)))
299
d4b21b08 300(defun type-hierarchy (type)
301 (let ((type-number (find-type-number type t)))
302 (unless (= type-number 0)
303 (cons type-number (type-hierarchy (type-parent type-number))))))
304
305(defbinding (type-is-p "g_type_is_a") (type super) boolean
306 ((find-type-number type) type-number)
307 ((find-type-number super) type-number))
308
309(defbinding %type-children () pointer
310 (type-number type-number)
311 (num-children unsigned-int :out))
312
313(defun map-subtypes (function type &optional prefix)
314 (let ((type-number (find-type-number type t)))
315 (multiple-value-bind (array length) (%type-children type-number)
316 (unwind-protect
d168bafd 317 (map-c-vector
d4b21b08 318 'nil
319 #'(lambda (type-number)
320 (when (or
321 (not prefix)
322 (string-prefix-p prefix (find-type-name type-number)))
323 (funcall function type-number))
324 (map-subtypes function type-number prefix))
325 array 'type-number length)
326 (deallocate-memory array)))))
327
328(defun find-types (prefix)
329 (let ((type-list nil))
e77e7713 330 (maphash
331 #'(lambda (type-number expander)
332 (declare (ignore expander))
333 (map-subtypes
334 #'(lambda (type-number)
335 (pushnew type-number type-list))
336 type-number prefix))
337 *derivable-type-info*)
d4b21b08 338 type-list))
339
340(defun %sort-types-topologicaly (unsorted)
341 (let ((sorted ()))
342 (loop while unsorted do
343 (dolist (type unsorted)
337933d8 344 (let ((dependencies
345 (append (rest (type-hierarchy type)) (type-interfaces type))))
d4b21b08 346 (cond
347 ((null dependencies)
348 (push type sorted)
349 (setq unsorted (delete type unsorted)))
350 (t
351 (unless (dolist (dep dependencies)
e77e7713 352 (when (find type (rest (type-hierarchy dep)))
353 (error "Cyclic type dependencie"))
d4b21b08 354 (return-if (find dep unsorted)))
355 (push type sorted)
356 (setq unsorted (delete type unsorted))))))))
357 (nreverse sorted)))
358
359
360(defun expand-type-definitions (prefix &optional args)
e77e7713 361 (flet ((type-options (type-number)
d4b21b08 362 (let ((name (find-type-name type-number)))
4de90d10 363 (cdr (assoc name args :test #'string=)))))
d4b21b08 364
e77e7713 365 (let ((type-list
366 (delete-if
367 #'(lambda (type-number)
368 (let ((name (find-type-name type-number)))
369 (or
370 (getf (type-options type-number) :ignore)
371 (find-if
372 #'(lambda (options)
373 (and
374 (string-prefix-p (first options) name)
80a09c29 375 (getf (cdr options) :ignore-prefix)
376 (not (some
377 #'(lambda (exception)
378 (string= name exception))
379 (getf (cdr options) :except)))))
e77e7713 380 args))))
381 (find-types prefix))))
d4b21b08 382
e77e7713 383 (dolist (type-number type-list)
384 (let ((name (find-type-name type-number)))
385 (register-type
386 (getf (type-options type-number) :type (default-type-name name))
387 type-number)))
388
389 `(progn
390 ,@(mapcar
391 #'(lambda (type)
392 (expand-type-definition type (type-options type)))
393 (%sort-types-topologicaly type-list))))))
394
d4b21b08 395(defmacro define-types-by-introspection (prefix &rest args)
4de90d10 396 (expand-type-definitions prefix args))
e77e7713 397
398
399