chiark / gitweb /
Small bug fix
[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
73572c12 18;; $Id: gtype.lisp,v 1.25 2005-02-03 23:09:04 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)
73572c12 59 (declare (ignore type args))
e74cfcab 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)
73572c12 65 (declare (ignore type args))
e74cfcab 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)))))
73572c12 134 (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)
73572c12 163 (let ((process (run-program
164 "/usr/bin/nm" (list "--defined-only" "-D" (namestring (truename pathname)))
d4b21b08 165 :output :stream :wait nil))
166 (fnames ()))
167 (labels ((read-symbols ()
73572c12 168 (let ((line (read-line (process-output process) nil)))
d4b21b08 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)
73572c12 179 (process-close process)
d4b21b08 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
62f12808 263;;;; Introspection of type information
d4b21b08 264
e77e7713 265(defvar *derivable-type-info* (make-hash-table))
d4b21b08 266
62f12808 267(defun register-derivable-type (type id expander &optional dependencies)
d4b21b08 268 (register-type type id)
e77e7713 269 (let ((type-number (register-type type id)))
62f12808 270 (setf
271 (gethash type-number *derivable-type-info*)
272 (list expander dependencies))))
d4b21b08 273
4de90d10 274(defun find-type-info (type)
275 (dolist (super (cdr (type-hierarchy type)))
e77e7713 276 (let ((info (gethash super *derivable-type-info*)))
4de90d10 277 (return-if info))))
278
62f12808 279(defun expand-type-definition (type forward-p options)
280 (let ((expander (first (find-type-info type))))
281 (funcall expander (find-type-number type t) forward-p options)))
d4b21b08 282
d4b21b08 283(defbinding type-parent (type) type-number
284 ((find-type-number type t) type-number))
285
286(defun supertype (type)
287 (type-from-number (type-parent type)))
288
337933d8 289(defbinding %type-interfaces (type) pointer
290 ((find-type-number type t) type-number)
291 (n-interfaces unsigned-int :out))
292
293(defun type-interfaces (type)
294 (multiple-value-bind (array length) (%type-interfaces type)
295 (unwind-protect
d168bafd 296 (map-c-vector 'list #'identity array 'type-number length)
337933d8 297 (deallocate-memory array))))
298
299(defun implements (type)
300 (mapcar #'type-from-number (type-interfaces type)))
301
d4b21b08 302(defun type-hierarchy (type)
303 (let ((type-number (find-type-number type t)))
304 (unless (= type-number 0)
305 (cons type-number (type-hierarchy (type-parent type-number))))))
306
307(defbinding (type-is-p "g_type_is_a") (type super) boolean
308 ((find-type-number type) type-number)
309 ((find-type-number super) type-number))
310
311(defbinding %type-children () pointer
312 (type-number type-number)
313 (num-children unsigned-int :out))
314
315(defun map-subtypes (function type &optional prefix)
316 (let ((type-number (find-type-number type t)))
317 (multiple-value-bind (array length) (%type-children type-number)
318 (unwind-protect
d168bafd 319 (map-c-vector
d4b21b08 320 'nil
321 #'(lambda (type-number)
322 (when (or
323 (not prefix)
324 (string-prefix-p prefix (find-type-name type-number)))
325 (funcall function type-number))
326 (map-subtypes function type-number prefix))
327 array 'type-number length)
328 (deallocate-memory array)))))
329
330(defun find-types (prefix)
331 (let ((type-list nil))
e77e7713 332 (maphash
333 #'(lambda (type-number expander)
334 (declare (ignore expander))
335 (map-subtypes
336 #'(lambda (type-number)
337 (pushnew type-number type-list))
338 type-number prefix))
339 *derivable-type-info*)
d4b21b08 340 type-list))
341
62f12808 342(defun find-type-dependencies (type)
343 (let ((list-dependencies (second (find-type-info type))))
344 (when list-dependencies
345 (funcall list-dependencies (find-type-number type t)))))
346
347(defun %sort-types-topologicaly (types)
348 (let ((unsorted (mapcar
349 #'(lambda (type)
350 (cons type (remove-if #'(lambda (dep)
351 (not (find dep types)))
352 (find-type-dependencies type))))
353 types))
354 (forward-define ())
355 (sorted ()))
356
357 (loop
358 as tmp = unsorted then (or (rest tmp) unsorted)
359 while tmp
360 do (destructuring-bind (type . dependencies) (first tmp)
d4b21b08 361 (cond
62f12808 362 ((every #'(lambda (dep)
363 (or (find dep forward-define) (find dep sorted)))
364 dependencies)
d4b21b08 365 (push type sorted)
62f12808 366 (setq unsorted (delete type unsorted :key #'first)))
367 ((some #'(lambda (dep)
368 (find type (find-type-dependencies dep)))
369 dependencies)
370 (push type forward-define)))))
371
372 (values (nreverse sorted) forward-define)))
d4b21b08 373
374
375(defun expand-type-definitions (prefix &optional args)
e77e7713 376 (flet ((type-options (type-number)
d4b21b08 377 (let ((name (find-type-name type-number)))
4de90d10 378 (cdr (assoc name args :test #'string=)))))
d4b21b08 379
e77e7713 380 (let ((type-list
381 (delete-if
382 #'(lambda (type-number)
383 (let ((name (find-type-name type-number)))
384 (or
385 (getf (type-options type-number) :ignore)
386 (find-if
387 #'(lambda (options)
388 (and
389 (string-prefix-p (first options) name)
80a09c29 390 (getf (cdr options) :ignore-prefix)
391 (not (some
392 #'(lambda (exception)
393 (string= name exception))
394 (getf (cdr options) :except)))))
e77e7713 395 args))))
396 (find-types prefix))))
d4b21b08 397
e77e7713 398 (dolist (type-number type-list)
399 (let ((name (find-type-name type-number)))
400 (register-type
401 (getf (type-options type-number) :type (default-type-name name))
402 type-number)))
62f12808 403
404 (multiple-value-bind (sorted-type-list forward-define)
405 (%sort-types-topologicaly type-list)
406 `(progn
407 ,@(mapcar
408 #'(lambda (type)
409 (expand-type-definition type t (type-options type)))
410 forward-define)
411 ,@(mapcar
412 #'(lambda (type)
413 (expand-type-definition type nil (type-options type)))
414 sorted-type-list))))))
e77e7713 415
d4b21b08 416(defmacro define-types-by-introspection (prefix &rest args)
4de90d10 417 (expand-type-definitions prefix args))