chiark / gitweb /
Changed the alloc argument to translate-from-alien to be one of :static, :reference...
[clg] / gdk / gdk.lisp
CommitLineData
560af5c5 1;; Common Lisp bindings for GTK+ v1.2.x
2;; Copyright (C) 1999 Espen S. Johnsen <espejohn@online.no>
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
bb110f5f 18;; $Id: gdk.lisp,v 1.2 2000-08-23 17:32:30 espen Exp $
560af5c5 19
20
21(in-package "GDK")
22
23
24;;; Events
25
26; (defmethod initialize-instance ((event event) &rest initargs &key)
27; (declare (ignore initargs))
28; (call-next-method)
29; )
30
31(defun find-event-class (event-type)
32 (find-class
33 (ecase event-type
34 (:expose 'expose-event)
35 (:delete 'delete-event))))
36
37(deftype-method alien-copier event (type-spec)
38 (declare (ignore type-spec))
39 '%event-copy)
40
41(deftype-method alien-deallocator event (type-spec)
42 (declare (ignore type-spec))
43 '%event-free)
44
45(deftype-method translate-from-alien
bb110f5f 46 event (type-spec location &optional (alloc :reference))
560af5c5 47 `(let ((location ,location))
48 (unless (null-pointer-p location)
49 (let ((event-class
50 (find-event-class
51 (funcall (get-reader-function 'event-type) location 0))))
52 ,(ecase alloc
bb110f5f 53 (:copy '(ensure-alien-instance event-class location))
560af5c5 54 (:static '(ensure-alien-instance event-class location :static t))
bb110f5f 55 (:reference '(ensure-alien-instance
56 event-class (%event-copy location))))))))
560af5c5 57
58
59(define-foreign event-poll-fd () int)
60
61(define-foreign ("gdk_events_pending" events-pending-p) () boolean)
62
63(define-foreign event-get () event)
64
65(define-foreign event-peek () event)
66
67(define-foreign event-get-graphics-expose () event
68 (window window))
69
70(define-foreign event-put () event
71 (event event))
72
73(define-foreign %event-copy (event &optional size) pointer
74 (event (or event pointer)))
75
76(define-foreign %event-free () nil
77 (event (or event pointer)))
78
79(define-foreign event-get-time () (unsigned 32)
80 (event event))
81
82;(define-foreign event-handler-set () ...)
83
84(define-foreign set-show-events () nil
85 (show-events boolean))
86
87;;; Misc
88
89(define-foreign set-use-xshm () nil
90 (use-xshm boolean))
91
92(define-foreign get-show-events () boolean)
93
94(define-foreign get-use-xshm () boolean)
95
96(define-foreign get-display () string)
97
98; (define-foreign time-get () (unsigned 32))
99
100; (define-foreign timer-get () (unsigned 32))
101
102; (define-foreign timer-set () nil
103; (milliseconds (unsigned 32)))
104
105; (define-foreign timer-enable () nil)
106
107; (define-foreign timer-disable () nil)
108
109; input ...
110
111(define-foreign pointer-grab () int
112 (window window)
113 (owner-events boolean)
114 (event-mask event-mask)
115 (confine-to (or null window))
116 (cursor (or null cursor))
117 (time (unsigned 32)))
118
119(define-foreign pointer-ungrab () nil
120 (time (unsigned 32)))
121
122(define-foreign keyboard-grab () int
123 (window window)
124 (owner-events boolean)
125 (time (unsigned 32)))
126
127(define-foreign keyboard-ungrab () nil
128 (time (unsigned 32)))
129
130(define-foreign ("gdk_pointer_is_grabbed" pointer-is-grabbed-p) () boolean)
131
132(define-foreign screen-width () int)
133(define-foreign screen-height () int)
134
135(define-foreign screen-width-mm () int)
136(define-foreign screen-height-mm () int)
137
138(define-foreign flush () nil)
139(define-foreign beep () nil)
140
141(define-foreign key-repeat-disable () nil)
142(define-foreign key-repeat-restore () nil)
143
144
145
146;;; Visuals
147
148(define-foreign visual-get-best-depth () int)
149
150(define-foreign visual-get-best-type () visual-type)
151
152(define-foreign visual-get-system () visual)
153
154
155(define-foreign
156 ("gdk_visual_get_best" %visual-get-best-with-nothing) () visual)
157
158(define-foreign %visual-get-best-with-depth () visual
159 (depth int))
160
161(define-foreign %visual-get-best-with-type () visual
162 (type visual-type))
163
164(define-foreign %visual-get-best-with-both () visual
165 (depth int)
166 (type visual-type))
167
168(defun visual-get-best (&key depth type)
169 (cond
170 ((and depth type) (%visual-get-best-with-both depth type))
171 (depth (%visual-get-best-with-depth depth))
172 (type (%visual-get-best-with-type type))
173 (t (%visual-get-best-with-nothing))))
174
175;(define-foreign query-depths ..)
176
177;(define-foreign query-visual-types ..)
178
179(define-foreign list-visuals () (double-list visual))
180
181
182;;; Windows
183
184; (define-foreign window-new ... )
185
186(define-foreign window-destroy () nil
187 (window window))
188
189
190; (define-foreign window-at-pointer () window
191; (window window)
192; (x int :in-out)
193; (y int :in-out))
194
195(define-foreign window-show () nil
196 (window window))
197
198(define-foreign window-hide () nil
199 (window window))
200
201(define-foreign window-withdraw () nil
202 (window window))
203
204(define-foreign window-move () nil
205 (window window)
206 (x int)
207 (y int))
208
209(define-foreign window-resize () nil
210 (window window)
211 (width int)
212 (height int))
213
214(define-foreign window-move-resize () nil
215 (window window)
216 (x int)
217 (y int)
218 (width int)
219 (height int))
220
221(define-foreign window-reparent () nil
222 (window window)
223 (new-parent window)
224 (x int)
225 (y int))
226
227(define-foreign window-clear () nil
228 (window window))
229
230(unexport
231 '(window-clear-area-no-e window-clear-area-e))
232
233(define-foreign ("gdk_window_clear_area" window-clear-area-no-e) () nil
234 (window window)
235 (x int) (y int) (width int) (height int))
236
237(define-foreign window-clear-area-e () nil
238 (window window)
239 (x int) (y int) (width int) (height int))
240
241(defun window-clear-area (window x y width height &optional expose)
242 (if expose
243 (window-clear-area-e window x y width height)
244 (window-clear-area-no-e window x y width height)))
245
246; (define-foreign window-copy-area () nil
247; (window window)
248; (gc gc)
249; (x int)
250; (y int)
251; (source-window window)
252; (source-x int)
253; (source-y int)
254; (width int)
255; (height int))
256
257(define-foreign window-raise () nil
258 (window window))
259
260(define-foreign window-lower () nil
261 (window window))
262
263; (define-foreign window-set-user-data () nil
264
265(define-foreign window-set-override-redirect () nil
266 (window window)
267 (override-redirect boolean))
268
269; (define-foreign window-add-filter () nil
270
271; (define-foreign window-remove-filter () nil
272
273(define-foreign window-shape-combine-mask () nil
274 (window window)
275 (shape-mask bitmap)
276 (offset-x int)
277 (offset-y int))
278
279(define-foreign window-set-child-shapes () nil
280 (window window))
281
282(define-foreign window-merge-child-shapes () nil
283 (window window))
284
285(define-foreign ("gdk_window_is_visible" window-is-visible-p) () boolean
286 (window window))
287
288(define-foreign ("gdk_window_is_viewable" window-is-viewable-p) () boolean
289 (window window))
290
291(define-foreign window-set-static-gravities () boolean
292 (window window)
293 (use-static boolean))
294
295; (define-foreign add-client-message-filter ...
296
297
298;;; Drag and Drop
299
300(define-foreign drag-context-new () drag-context)
301
302(define-foreign drag-context-ref () nil
303 (context drag-context))
304
305(define-foreign drag-context-unref () nil
306 (context drag-context))
307
308;; Destination side
309
310(define-foreign drag-status () nil
311 (context drag-context)
312 (action drag-action)
313 (time (unsigned 32)))
314
315
316
317
318(define-foreign window-set-cursor () nil
319 (window window)
320 (cursor cursor))
321
322(define-foreign window-get-pointer () window
323 (window window)
324 (x int :out)
325 (y int :out)
326 (mask modifier-type :out))
327
328(define-foreign get-root-window () window)
329
330
331
332;;
333
334(define-foreign rgb-init () nil)
335
336
337
338
339;;; Cursor
340
341(deftype-method alien-ref cursor (type-spec)
342 (declare (ignore type-spec))
343 '%cursor-ref)
344
345(deftype-method alien-unref cursor (type-spec)
346 (declare (ignore type-spec))
347 '%cursor-unref)
348
349
350(define-foreign cursor-new () cursor
351 (cursor-type cursor-type))
352
353(define-foreign cursor-new-from-pixmap () cursor
354 (source pixmap)
355 (mask bitmap)
356 (foreground color)
357 (background color)
358 (x int) (y int))
359
360(define-foreign %cursor-ref () pointer
361 (cursor (or cursor pointer)))
362
363(define-foreign %cursor-unref () nil
364 (cursor (or cursor pointer)))
365
366
367
368;;; Pixmaps
369
bb110f5f 370;; See the class definition for an explanation of this
371(deftype-method alien-ref bitmap (type-spec)
372 (declare (ignore type-spec))
373 '%drawable-ref)
374
375(deftype-method alien-unref bitmap (type-spec)
376 (declare (ignore type-spec))
377 '%drawable-unref)
378
379(define-foreign %drawable-ref () pointer
380 (object (or bitmap pointer)))
381
382(define-foreign %drawable-unref () nil
383 (object (or bitmap pointer)))
384
385
560af5c5 386(define-foreign pixmap-new (width height depth &key window) pixmap
387 (width int)
388 (height int)
389 (depth int)
390 (window (or null window)))
391
560af5c5 392(define-foreign %pixmap-colormap-create-from-xpm () pixmap
393 (window (or null window))
394 (colormap (or null colormap))
395 (mask bitmap :out)
396 (color (or null color))
397 (filename string))
398
399(define-foreign pixmap-colormap-create-from-xpm-d () pixmap
400 (window (or null window))
401 (colormap (or null colormap))
402 (mask bitmap :out)
403 (color (or null color))
404 (data pointer))
405
bb110f5f 406(defun pixmap-create (source &key color window colormap)
407 (let ((window
408 (if (not (or window colormap))
409 (get-root-window)
410 window)))
411 (multiple-value-bind (pixmap mask)
412 (typecase source
413 ((or string pathname)
414 (%pixmap-colormap-create-from-xpm
415 window colormap color (namestring (truename source))))
560af5c5 416; (t
417; (with-array (data :initial-contents source :free-contents t)
bb110f5f 418; (pixmap-colormap-create-from-xpm-d window colormap color data)))
419 )
420 (unreference-instance pixmap)
421 (unreference-instance mask)
422 (values pixmap mask))))
560af5c5 423
424
425
426;;; Color
427
428(defun %scale-value (value)
429 (etypecase value
430 (integer value)
431 (float (truncate (* value 65535)))))
432
433(defmethod initialize-instance ((color color) &rest initargs
434 &key (colors #(0 0 0)) red green blue)
435 (declare (ignore initargs))
436 (call-next-method)
437 (with-slots ((%red red) (%green green) (%blue blue)) color
438 (setf
439 %red (%scale-value (or red (svref colors 0)))
440 %green (%scale-value (or green (svref colors 1)))
441 %blue (%scale-value (or blue (svref colors 2))))))
442
443
444(defun ensure-color (color)
445 (etypecase color
446 (null nil)
447 (color color)
448 (vector (make-instance 'color :colors color))))
449
450
451
452;;; Fonts
453
454(define-foreign font-load () font
455 (font-name string))
456
457(defun ensure-font (font)
458 (etypecase font
459 (null nil)
460 (font font)
461 (string (font-load font))))
462
463(define-foreign fontset-load () font
464 (fontset-name string))
465
466(define-foreign font-ref () font
467 (font font))
468
469(define-foreign font-unref () nil
470 (font font))
471
472(defun font-maybe-unref (font1 font2)
473 (unless (eq font1 font2)
474 (font-unref font1)))
475
476(define-foreign font-id () int
477 (font font))
478
479(define-foreign ("gdk_font_equal" font-equalp) () boolean
480 (font-a font)
481 (font-b font))
482
483(define-foreign string-width () int
484 (font font)
485 (string string))
486
487(define-foreign text-width
488 (font text &aux (length (length text))) int
489 (font font)
490 (text string)
491 (length int))
492
493; (define-foreign ("gdk_text_width_wc" text-width-wc)
494; (font text &aux (length (length text))) int
495; (font font)
496; (text string)
497; (length int))
498
499(define-foreign char-width () int
500 (font font)
501 (char char))
502
503; (define-foreign ("gdk_char_width_wc" char-width-wc) () int
504; (font font)
505; (char char))
506
507
508(define-foreign string-measure () int
509 (font font)
510 (string string))
511
512(define-foreign text-measure
513 (font text &aux (length (length text))) int
514 (font font)
515 (text string)
516 (length int))
517
518(define-foreign char-measure () int
519 (font font)
520 (char char))
521
522(define-foreign string-height () int
523 (font font)
524 (string string))
525
526(define-foreign text-height
527 (font text &aux (length (length text))) int
528 (font font)
529 (text string)
530 (length int))
531
532(define-foreign char-height () int
533 (font font)
534 (char char))
535
536
537;;; Drawing functions
538
539(define-foreign draw-rectangle () nil
540 (drawable (or window pixmap bitmap))
541 (gc gc) (filled boolean)
542 (x int) (y int) (width int) (height int))
543
544
545;;; Key values
546
547(define-foreign keyval-name () string
548 (keyval unsigned-int))
549
550(define-foreign keyval-from-name () unsigned-int
551 (name string))
552
553(define-foreign keyval-to-upper () unsigned-int
554 (keyval unsigned-int))
555
556(define-foreign keyval-to-lower ()unsigned-int
557 (keyval unsigned-int))
558
559(define-foreign ("gdk_keyval_is_upper" keyval-is-upper-p) () boolean
560 (keyval unsigned-int))
561
562(define-foreign ("gdk_keyval_is_lower" keyval-is-lower-p) () boolean
563 (keyval unsigned-int))
564