chiark / gitweb /
Made multi threading work on recent versions of SBCL
[clg] / gdk / gdk.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: gdk.lisp,v 1.48 2008-01-02 15:26:46 espen Exp $
24
25
26 (in-package "GDK")
27
28 ;;; Initialization
29  
30 (defbinding (gdk-init "gdk_parse_args") () nil
31   "Initializes the library without opening the display."
32   (nil null)
33   (nil null))
34
35
36
37 ;;; Display
38
39 #-debug-ref-counting
40 (defmethod print-object ((display display) stream)
41   (if (and (proxy-valid-p display) (slot-boundp display 'name))
42       (print-unreadable-object (display stream :type t :identity nil)
43         (format stream "~S at 0x~X" 
44          (display-name display) (pointer-address (foreign-location display))))
45     (call-next-method)))
46
47 (defbinding %display-open () display
48   (display-name (or null string)))
49
50 (defvar *display-aliases* ())
51
52 (defun display-add-alias (display alias)
53   (unless (rassoc display *display-aliases*)
54     (signal-connect display 'closed
55      #'(lambda (is-error-p)
56          (declare (ignore is-error-p))
57          (setq *display-aliases* 
58           (delete-if #'(lambda (mapping)
59                          (eq (cdr mapping) display))
60            *display-aliases*))))
61     (push (cons alias display) *display-aliases*)))
62
63
64 (defun display-open (&optional name)
65   (let ((display (or
66                   (%display-open name)
67                   (error "Opening display failed: ~A" name))))
68     (unless (display-get-default)
69       (display-set-default display))
70     (when (and (stringp name) (not (string= name (display-name display))))
71       (display-add-alias display name))
72     display))
73
74 (defbinding %display-get-n-screens () int
75   (display display))
76
77 (defbinding %display-get-screen () screen
78   (display display)
79   (screen-num int))
80
81 (defun display-screens (&optional (display (display-get-default)))
82   (loop
83    for i from 0 below (%display-get-n-screens display)
84    collect (%display-get-screen display i)))
85
86 (defbinding display-get-default-screen 
87     (&optional (display (display-get-default))) screen
88   (display display))
89
90 (defbinding display-beep (&optional (display (display-get-default))) nil
91   (display display))
92
93 (defbinding display-sync (&optional (display (display-get-default))) nil
94   (display display))
95
96 (defbinding display-flush (&optional (display (display-get-default))) nil
97   (display display))
98
99 (defbinding display-close (&optional (display (display-get-default))) nil
100   ((ensure-display display t) display))
101
102 (defbinding flush () nil)
103
104 (defbinding display-get-event
105     (&optional (display (display-get-default))) event
106   (display display))
107
108 (defbinding display-peek-event
109     (&optional (display (display-get-default))) event
110   (display display))
111
112 (defbinding display-put-event
113     (event &optional (display (display-get-default))) event
114   (display display)
115   (event event))
116
117 (defbinding (display-connection-number "clg_gdk_connection_number")
118     (&optional (display (display-get-default))) int
119   (display display))
120
121 (defun find-display (name &optional (error-p t))
122   (or
123    (find name (list-displays) :key #'display-name :test #'string=)
124    (cdr (assoc name *display-aliases* :test #'string=))
125    (when error-p
126      (error "No such display: ~A" name))))
127
128 ;; This will not detect connections to the same server that use
129 ;; different hostnames
130 (defun %find-similar-display (display)
131    (find (display-name display) (delete display (list-displays))
132     :key #'display-name :test #'string=))
133
134 (defun ensure-display (display &optional existing-only-p)
135   (etypecase display
136     (null (display-get-default))
137     (display display)
138     (string (or 
139              (find-display display existing-only-p)
140              (let* ((new (display-open display))
141                     (existing (%find-similar-display new)))
142                (if existing
143                    (progn
144                      (display-add-alias existing display)
145                      (display-close new)
146                      existing)
147                  new))))))
148
149
150 ;;; Display manager
151
152 (defbinding display-get-default () display)
153
154 (defbinding (display-set-default "gdk_display_manager_set_default_display")
155     (display) nil
156   ((display-manager) display-manager)
157   (display display))
158
159 (defbinding (list-displays "gdk_display_manager_list_displays") ()
160     (gslist (static display))
161   ((display-manager) display-manager))
162
163 ;; The only purpose of exporting this is to make it possible for
164 ;; applications to connect to the display-opened signal
165 (defbinding (display-manager "gdk_display_manager_get") () display-manager)
166
167 (defbinding display-get-core-pointer 
168     (&optional (display (display-get-default))) device
169   (display display))
170
171 (defmacro with-default-display ((display) &body body)
172   (let ((saved-display (make-symbol "SAVED-DISPLAY"))
173         (current-display (make-symbol "CURRENT-DISPLAY")))
174     `(let* ((,current-display ,display)
175             (,saved-display (when ,current-display
176                               (prog1
177                                   (display-get-default)
178                                 (display-set-default (ensure-display ,current-display))))))
179        (unwind-protect 
180            (progn ,@body)
181          (when ,saved-display
182            (display-set-default ,saved-display))))))
183
184
185 ;;; Primitive graphics structures (points, rectangles and regions)
186
187 (defbinding %rectangle-intersect () boolean
188   (src1 rectangle)
189   (src2 rectangle)
190   (dest rectangle))
191
192 (defun rectangle-intersect (src1 src2 &optional (dest (make-instance 'rectangle)))
193   "Calculates the intersection of two rectangles. It is allowed for DEST to be the same as either SRC1 or SRC2. DEST is returned if the to rectangles intersect, otherwise NIL" 
194   (when (%rectangle-intersect src1 src2 dest)
195     dest))
196
197 (defbinding rectangle-union (src1 src2 &optional (dest (make-instance 'rectangle))) nil
198   "Calculates the union of two rectangles. The union of rectangles SRC1 and SRC2 is the smallest rectangle which includes both SRC1 and SRC2 within it. It is allowed for DEST to be the same as either SRC1 or SRC2." 
199   (src1 rectangle)
200   (src2 rectangle)
201   (dest rectangle :in/return))
202
203 (defun ensure-rectangle (rectangle)
204   (etypecase rectangle 
205     (rectangle rectangle)
206     (vector (make-instance 'rectangle 
207              :x (aref rectangle 0) :y (aref rectangle 1)
208              :width (aref rectangle 2) :height (aref rectangle 3)))))
209
210
211 (defbinding %region-new () pointer)
212
213 (defbinding %region-polygon () pointer
214   (points (vector (inlined point)))
215   (n-points int)
216   (fill-rule fill-rule))
217
218 (defbinding %region-rectangle () pointer
219   (rectangle rectangle))
220
221 (defbinding %region-copy () pointer
222   (location pointer))
223
224 (defbinding %region-destroy () nil
225   (location pointer))
226
227 (defmethod allocate-foreign ((region region) &key rectangle polygon fill-rule)
228   (cond
229    ((and rectangle polygon) 
230     (error "Only one of the keyword arguments :RECTANGLE and :POLYGON can be specified"))
231    (rectangle (%region-rectangle (ensure-rectangle rectangle)))
232    (polygon (%region-polygon polygon (length polygon) fill-rule))
233    ((%region-new))))
234
235 (defun ensure-region (region)
236   (etypecase region 
237     (region region)
238     ((or rectangle vector) 
239      (make-instance 'region :rectangle (ensure-rectangle region)))
240     (list
241      (make-instance 'region :polygon region))))
242
243 (defbinding region-get-clipbox (region &optional (rectangle (make-instance 'rectangle))) nil
244   (region region)
245   (rectangle rectangle :in/return))
246
247 (defbinding %region-get-rectangles () nil
248   (region region)
249   (rectangles pointer :out)
250   (n-rectangles int :out))
251
252 (defun region-get-rectangles (region)
253   "Obtains the area covered by the region as a list of rectangles."
254   (multiple-value-bind (location length) (%region-get-rectangles region)
255     (prog1
256         (map-c-vector 'list #'identity location '(inlined rectangle) length :get)
257       (deallocate-memory location))))
258
259 (defbinding region-empty-p () boolean
260   (region region))
261
262 (defbinding region-equal-p () boolean
263   (region1 region)
264   (region2 region))
265
266 (defbinding region-point-in-p () boolean
267   (region region)
268   (x int)
269   (y int))
270
271 (defbinding region-rect-in (region rectangle) overlap-type
272   (region region)
273   ((ensure-rectangle rectangle) rectangle))
274
275 (defbinding region-offset () nil
276   (region region)
277   (dx int)
278   (dy int))
279
280 (defbinding region-shrink () nil
281   (region region)
282   (dx int)
283   (dy int))
284
285 (defbinding region-intersect (source1 source2) nil
286   ((ensure-region source1) region :in/return)
287   ((ensure-region source2) region))
288
289 (defbinding region-union (source1 source2) nil
290   ((ensure-region source1) region :in/return)
291   ((ensure-region source2) region))
292
293 (defbinding region-subtract (source1 source2) nil
294   ((ensure-region source1) region :in/return)
295   ((ensure-region source2) region))
296
297 (defbinding region-xor (source1 source2) nil
298   ((ensure-region source1) region :in/return)
299   ((ensure-region source2) region))
300
301
302 ;;; Events
303
304 (defbinding (events-pending-p "gdk_events_pending") () boolean)
305
306 (defbinding event-get () event)
307
308 (defbinding event-peek () event)
309
310 (defbinding event-get-graphics-expose () event
311   (window window))
312
313 (defbinding event-put () event
314   (event event))
315
316 ;(defbinding event-handler-set () ...)
317
318 (defbinding set-show-events () nil
319   (show-events boolean))
320
321 (defbinding get-show-events () boolean)
322
323
324 ;;; Miscellaneous functions
325
326 (defbinding screen-width () int
327   (screen screen))
328
329 (defbinding screen-height () int
330   (screen screen))
331
332 (defbinding screen-width-mm () int
333   (screen screen))
334
335 (defbinding screen-height-mm () int
336   (screen screen))
337
338
339 (defbinding pointer-grab 
340     (window &key owner-events events confine-to cursor time) grab-status
341   (window window)
342   (owner-events boolean)
343   (events event-mask)
344   (confine-to (or null window))
345   (cursor (or null cursor))
346   ((or time 0) (unsigned 32)))
347
348 (defbinding (pointer-ungrab "gdk_display_pointer_ungrab")
349     (&optional time (display (display-get-default))) nil
350   (display display)
351   ((or time 0) (unsigned 32)))
352
353 (defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed") 
354     (&optional (display (display-get-default))) boolean
355   (display display))
356
357 (defbinding keyboard-grab (window &key owner-events time) grab-status
358   (window window)
359   (owner-events boolean)
360   ((or time 0) (unsigned 32)))
361
362 (defbinding (keyboard-ungrab "gdk_display_keyboard_ungrab")
363     (&optional time (display (display-get-default))) nil
364   (display display)
365   ((or time 0) (unsigned 32)))
366
367
368
369 (defbinding atom-intern (atom-name &optional only-if-exists) atom
370   ((string atom-name) string)
371   (only-if-exists boolean))
372
373 (defbinding atom-name () string
374   (atom atom))
375
376
377
378 ;;; Visuals
379
380 (defbinding visual-get-best-depth () int)
381
382 (defbinding visual-get-best-type () visual-type)
383
384 (defbinding visual-get-system () visual)
385
386
387 (defbinding (%visual-get-best-with-nothing "gdk_visual_get_best") () visual)
388
389 (defbinding %visual-get-best-with-depth () visual
390   (depth int))
391
392 (defbinding %visual-get-best-with-type () visual
393   (type visual-type))
394
395 (defbinding %visual-get-best-with-both () visual
396   (depth int)
397   (type visual-type))
398
399 (defun visual-get-best (&key depth type)
400   (cond
401    ((and depth type) (%visual-get-best-with-both depth type))
402    (depth (%visual-get-best-with-depth depth))
403    (type (%visual-get-best-with-type type))
404    (t (%visual-get-best-with-nothing))))
405
406 ;(defbinding query-depths ..)
407
408 ;(defbinding query-visual-types ..)
409
410 (defbinding list-visuals () (glist visual))
411
412
413 ;;; Windows
414
415 (defbinding window-destroy () nil
416   (window window))
417
418 (defbinding window-at-pointer () window
419   (x int :out)
420   (y int :out))
421
422 (defbinding window-show () nil
423   (window window))
424
425 (defbinding window-show-unraised () nil
426   (window window))
427
428 (defbinding window-hide () nil
429   (window window))
430
431 (defbinding window-is-visible-p () boolean
432   (window window))
433
434 (defbinding window-is-viewable-p () boolean
435   (window window))
436
437 (defbinding window-withdraw () nil
438   (window window))
439
440 (defbinding window-iconify () nil
441   (window window))
442
443 (defbinding window-deiconify () nil
444   (window window))
445
446 (defbinding window-stick () nil
447   (window window))
448
449 (defbinding window-unstick () nil
450   (window window))
451
452 (defbinding window-maximize () nil
453   (window window))
454
455 (defbinding window-unmaximize () nil
456   (window window))
457
458 (defbinding window-fullscreen () nil
459   (window window))
460
461 (defbinding window-unfullscreen () nil
462   (window window))
463
464 (defbinding window-set-keep-above () nil
465   (window window)
466   (setting boolean))
467
468 (defbinding window-set-keep-below () nil
469   (window window)
470   (setting boolean))
471
472 (defbinding window-move () nil
473   (window window)
474   (x int)
475   (y int))
476
477 (defbinding window-resize () nil
478   (window window)
479   (width int)
480   (height int))
481
482 (defbinding window-move-resize () nil
483   (window window)
484   (x int)
485   (y int)
486   (width int)
487   (height int))
488
489 (defbinding window-scroll () nil
490   (window window)
491   (dx int)
492   (dy int))
493
494 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
495 (defbinding window-move-region (window region dx dy) nil
496   (window window)
497   ((ensure-region region) region)
498   (dx int)
499   (dy int))
500
501 (defbinding window-reparent () nil
502   (window window)
503   (new-parent window)
504   (x int)
505   (y int))
506
507 (defbinding window-clear () nil
508   (window window))
509
510 (defbinding %window-clear-area () nil
511   (window window)
512   (x int) (y int) (width int) (height int))
513
514 (defbinding %window-clear-area-e () nil
515   (window window)
516   (x int) (y int) (width int) (height int))
517
518 (defun window-clear-area (window x y width height &optional expose)
519   (if expose
520       (%window-clear-area-e window x y width height)
521     (%window-clear-area window x y width height)))
522
523 (defbinding window-raise () nil
524   (window window))
525
526 (defbinding window-lower () nil
527   (window window))
528
529 (defbinding window-focus () nil
530   (window window)
531   (timestamp unsigned-int))
532
533 (defbinding window-register-dnd () nil
534   (window window))
535
536 (defbinding window-begin-resize-drag () nil
537   (window window)
538   (edge window-edge)
539   (button int)
540   (root-x int)
541   (root-y int)
542   (timestamp unsigned-int))
543
544 (defbinding window-begin-move-drag () nil
545   (window window)
546   (button int)
547   (root-x int)
548   (root-y int)
549   (timestamp unsigned-int))
550
551 ;; Probably not needed
552 ;; (defbinding window-constrain-size () nil ..
553
554 (defbinding window-begin-paint-region (window region) nil
555   (window window)
556   ((ensure-region region) region))
557
558 (defbinding window-end-paint () nil
559   (window window))
560
561 (defmacro with-window-paint ((window region) &body body)
562   `(progn
563      (window-begin-paint-region ,window ,region)
564      (unwind-protect 
565          (progn ,@body)
566        (window-end-paint ,window))))
567
568 ;; TODO: create wrapper function and use gdk_window_invalidate_maybe_recurse 
569 ;; if last arg is a function
570 (defbinding window-invalidate-region (window region invalidate-children-p) nil
571   (window window)
572   ((ensure-region region) region)
573   (invalidate-children-p boolean))
574
575 (defbinding window-get-update-area () region
576   (window window))
577
578 (defbinding window-freeze-updates () nil
579   (window window))
580
581 (defbinding window-thaw-updates () nil
582   (window window))
583
584 (defbinding window-process-all-updates () nil)
585
586 (defbinding window-process-updates () nil
587   (window window)
588   (update-children-p boolean))
589
590 (defbinding window-set-debug-updates () nil
591   (enable-p boolean))
592
593 (defbinding window-enable-synchronized-configure () nil
594   (window window))
595   
596 (defbinding window-configure-finished () nil
597   (window window))
598
599 ;; Deprecated, use gobject user data mechanism
600 (defbinding window-set-user-data () nil
601   (window window)
602   (user-data pointer))
603
604 (defbinding window-set-override-redirect () nil
605   (window window)
606   (override-redirect-p boolean))
607
608 (defbinding window-set-accept-focus () nil
609   (window window)
610   (accept-focus-p boolean))
611
612 (defbinding window-set-focus-on-map () nil
613   (window window)
614   (focus-on-map-p boolean))
615
616 ;; Added if needed
617 ; (defbinding window-add-filter () nil
618 ; (defbinding window-remove-filter () nil
619
620 ;; New code should use window-shape-combine
621 (defbinding window-shape-combine-mask () nil
622   (window window)
623   (shape-mask bitmap)
624   (offset-x int)
625   (offset-y int))
626
627 (defbinding %window-shape-combine-region () nil
628   (window window)
629   (region (or null region))
630   (offset-x int)
631   (offset-y int))
632
633 (defun window-shape-combine (window shape offset-x offset-y)
634   (etypecase shape
635     (null (%window-shape-combine-region window nil 0 0))
636     (region (%window-shape-combine-region window shape offset-x offset-y))
637     (bitmap (window-shape-combine-mask window shape offset-x offset-y))))
638
639 (defbinding window-set-child-shapes () nil
640   (window window))
641
642 (defbinding window-merge-child-shapes () nil
643   (window window))
644
645 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
646 (progn
647   (defbinding %window-input-shape-combine-mask () nil
648     (window window)
649     (shape-mask bitmap)
650     (x int)
651     (y int))
652
653   (defbinding %window-input-shape-combine-region () nil
654     (window window)
655     (region (or null region))
656     (x int)
657     (y int))
658   
659   (defun window-input-shape-combine (window shape x y)
660     (etypecase shape
661       (null (%window-input-shape-combine-region window nil 0 0))
662       (region (%window-input-shape-combine-region window shape x y))
663       (bitmap (%window-input-shape-combine-mask window shape x y))))
664
665   (defbinding window-set-child-input-shapes () nil
666     (window window))
667   
668   (defbinding window-merge-child-input-shapes () nil
669     (window window)))
670
671 (defbinding window-set-static-gravities () boolean
672   (window window)
673   (use-static-p boolean))
674
675 (defbinding window-set-title () nil
676   (window window)
677   (title string))
678
679 (defbinding window-set-background () nil
680   (window window)
681   (color color))
682
683 (defbinding window-set-back-pixmap (window pixmap &optional parent-relative-p) nil
684   (window window)
685   (pixmap (or null pixmap))
686   (parent-relative-p boolean))
687
688 (defbinding window-set-cursor () nil
689   (window window)
690   (cursor (or null cursor)))
691
692 (defbinding window-get-geometry () nil
693   (window window)
694   (x int :out)
695   (y int :out)
696   (width int :out)
697   (height int :out)
698   (depth int :out))
699
700 ;(defbinding window-set-geometry-hints () nil
701
702 (defbinding window-set-icon-list () nil
703   (window window)
704   (icons (glist pixbufs)))
705
706 (defbinding window-set-skip-taskbar-hint () nil
707   (window window)
708   (skip-taskbar-p boolean))
709
710 (defbinding window-set-skip-pager-hint () nil
711   (window window)
712   (skip-pager-p boolean))
713
714 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
715 (defbinding window-set-urgency-hint () nil
716   (window window)
717   (urgent-p boolean))
718
719 (defbinding window-get-position () nil
720   (window window)
721   (x int :out)
722   (y int :out))
723
724 (defbinding window-get-root-origin () nil
725   (window window)
726   (x int :out)
727   (y int :out))
728
729 (defbinding window-get-frame-extents (window &optional (extents (make-instance 'rect))) nil
730   (window window)
731   (extents rectangle :in/return))
732
733 (defbinding window-get-origin () nil ; this may not work as
734   (window window)                    ; an int is actually returned
735   (x int :out)
736   (y int :out))
737
738 (defbinding window-get-pointer () window
739   (window window)
740   (x int :out)
741   (y int :out)
742   (mask modifier-type :out))
743
744 ;(defbinding window-set-icon () nil
745
746 (defbinding window-set-icon-name () nil
747   (window window)
748   (icon-name string))
749
750 (defbinding window-set-transient-for () nil
751   (window window)
752   (parent window))
753
754 (defbinding window-set-role () nil
755   (window window)
756   (role string))
757
758 (defbinding %window-get-decorations () boolean
759   (window window)
760   (decorations wm-decoration :out))
761
762 (defun %window-decorations-getter (window)
763   (nth-value 1 (%window-get-decorations window)))
764
765 (defun %window-decorations-boundp (window)
766   (%window-get-decorations window))
767
768 (defbinding %window-get-toplevels () (glist window))
769
770 (defun window-get-toplevels (&optional screen)
771   (if screen
772       (error "Not implemented")
773     (%window-get-toplevels)))
774
775 (defbinding %get-default-root-window () window)
776
777 (defun get-root-window (&optional display)
778   (if display
779       (error "Not implemented")
780     (%get-default-root-window)))
781
782
783
784 ;;; Drag and Drop
785
786 ;; Destination side
787
788 (defbinding drag-status () nil
789   (context drag-context)
790   (action drag-action)
791   (time (unsigned 32)))
792
793
794
795
796
797
798 ;;
799
800 (defbinding rgb-init () nil)
801
802
803
804
805 ;;; Cursor
806
807 (defmethod allocate-foreign ((cursor cursor) &key source mask fg bg 
808                              (x 0) (y 0) (display (display-get-default)))
809   (etypecase source
810     (keyword (%cursor-new-for-display display source))
811     (pixbuf (%cursor-new-from-pixbuf display source x y))
812     (pixmap (%cursor-new-from-pixmap source mask 
813              (or fg (ensure-color #(0.0 0.0 0.0)))
814              (or bg (ensure-color #(1.0 1.0 1.0))) x y))
815     (pathname (%cursor-new-from-pixbuf display (pixbuf-load source) x y))))
816
817 (defun ensure-cursor (cursor &rest args)
818   (if (typep cursor 'cursor)
819       cursor
820     (apply #'make-instance 'cursor :source cursor args)))
821
822 (defbinding %cursor-new-for-display () pointer
823   (display display)
824   (cursor-type cursor-type))
825
826 (defbinding %cursor-new-from-pixmap () pointer
827   (source pixmap)
828   (mask bitmap)
829   (foreground color)
830   (background color)
831   (x int) (y int))
832
833 (defbinding %cursor-new-from-pixbuf () pointer
834   (display display)
835   (pixbuf pixbuf)
836   (x int) (y int))
837
838 (defbinding %cursor-ref () pointer
839   (location pointer))
840
841 (defbinding %cursor-unref () nil
842   (location pointer))
843
844
845 ;;; Pixmaps
846
847 (defbinding %pixmap-new () pointer
848   (window (or null window))
849   (width int)
850   (height int)
851   (depth int))
852
853 (defmethod allocate-foreign ((pximap pixmap) &key width height depth window)
854   (%pixmap-new window (or width (drawable-width window)) (or height (drawable-height window)) (or depth -1)))
855
856 (defun pixmap-new (width height depth &key window)
857   (warn "PIXMAP-NEW is deprecated, use (make-instance 'pixmap ...) instead")
858   (make-instance 'pixmap :width width :height height :depth depth :window window))
859
860 (defbinding %pixmap-colormap-create-from-xpm () pixmap
861   (window (or null window))
862   (colormap (or null colormap))
863   (mask bitmap :out)
864   (color (or null color))
865   (filename pathname))
866
867 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
868   (window (or null window))
869   (colormap (or null colormap))
870   (mask bitmap :out)
871   (color (or null color))
872   (data (vector string)))
873
874 ;; Deprecated, use pixbufs instead
875 (defun pixmap-create (source &key color window colormap)
876   (let ((window
877          (if (not (or window colormap))
878              (get-root-window)
879            window)))
880     (multiple-value-bind (pixmap mask)
881         (etypecase source
882           ((or string pathname)
883            (%pixmap-colormap-create-from-xpm window colormap color  source))
884           ((vector string)
885            (%pixmap-colormap-create-from-xpm-d window colormap color source)))
886       (values pixmap mask))))
887
888
889 ;;; Color
890
891 (defbinding colormap-get-system () colormap)
892
893 (defbinding %color-copy () pointer
894   (location pointer))
895
896 (defmethod allocate-foreign ((color color)  &rest initargs)
897   (declare (ignore color initargs))
898   ;; Color structs are allocated as memory chunks by gdk, and since
899   ;; there is no gdk_color_new we have to use this hack to get a new
900   ;; color chunk
901   (with-memory (location #.(foreign-size (find-class 'color)))
902     (%color-copy location)))
903
904 (defun %scale-value (value)
905   (etypecase value
906     (integer value)
907     (float (truncate (* value 65535)))))
908
909 (defmethod initialize-instance ((color color) &key (red 0.0) (green 0.0) (blue 0.0))
910   (call-next-method)
911   (with-slots ((%red red) (%green green) (%blue blue)) color
912     (setf
913      %red (%scale-value red)
914      %green (%scale-value green)
915      %blue (%scale-value blue))))
916
917 (defbinding %color-parse () boolean
918   (spec string)
919   (color color :in/return))
920
921 (defun color-parse (spec &optional (color (make-instance 'color)))
922   (multiple-value-bind (succeeded-p color) (%color-parse spec color)
923     (if succeeded-p
924         color
925       (error "Parsing color specification ~S failed." spec))))
926
927 (defun ensure-color (color)
928   (etypecase color
929     (null nil)
930     (color color)
931     (string (color-parse color))
932     (vector
933      (make-instance 'color 
934       :red (svref color 0) :green (svref color 1) :blue (svref color 2)))))
935
936
937   
938 ;;; Drawable -- all the draw- functions are deprecated and will be
939 ;;; removed, use cairo for drawing instead.
940
941 (defbinding drawable-get-size () nil
942   (drawable drawable)
943   (width int :out)
944   (height int :out))
945
946 (defbinding (drawable-width "gdk_drawable_get_size") () nil
947   (drawable drawable)
948   (width int :out)
949   (nil null))
950
951 (defbinding (drawable-height "gdk_drawable_get_size") () nil
952   (drawable drawable)
953   (nil null)
954   (height int :out))
955
956 ;; (defbinding drawable-get-clip-region () region
957 ;;   (drawable drawable))
958
959 ;; (defbinding drawable-get-visible-region () region
960 ;;   (drawable drawable))
961
962 (defbinding draw-point () nil
963   (drawable drawable) (gc gc) 
964   (x int) (y int))
965
966 (defbinding %draw-points () nil
967   (drawable drawable) (gc gc) 
968   (points pointer)
969   (n-points int))
970
971 (defbinding draw-line () nil
972   (drawable drawable) (gc gc) 
973   (x1 int) (y1 int)
974   (x2 int) (y2 int))
975
976 (defbinding draw-pixbuf
977     (drawable gc pixbuf src-x src-y dest-x dest-y &optional
978      width height (dither :none) (x-dither 0) (y-dither 0)) nil
979   (drawable drawable) (gc (or null gc))
980   (pixbuf pixbuf)
981   (src-x int) (src-y int)
982   (dest-x int) (dest-y int)
983   ((or width -1) int) ((or height -1) int)
984   (dither rgb-dither)
985   (x-dither int) (y-dither int))
986
987 (defbinding draw-rectangle () nil
988   (drawable drawable) (gc gc) 
989   (filled boolean)
990   (x int) (y int) 
991   (width int) (height int))
992
993 (defbinding draw-arc () nil
994   (drawable drawable) (gc gc) 
995   (filled boolean)
996   (x int) (y int) 
997   (width int) (height int)
998   (angle1 int) (angle2 int))
999
1000 (defbinding %draw-layout () nil
1001   (drawable drawable) (gc gc) 
1002   (x int) (y int)
1003   (layout pango:layout))
1004
1005 (defbinding %draw-layout-with-colors () nil
1006   (drawable drawable) (gc gc) 
1007   (x int) (y int)
1008   (layout pango:layout)
1009   (foreground (or null color))
1010   (background (or null color)))
1011
1012 (defun draw-layout (drawable gc x y layout &optional foreground background)
1013   (if (or foreground background)
1014       (%draw-layout-with-colors drawable gc x y layout foreground background)
1015     (%draw-layout drawable gc x y layout)))
1016
1017 (defbinding draw-drawable 
1018     (drawable gc src src-x src-y dest-x dest-y &optional width height) nil
1019   (drawable drawable) (gc gc) 
1020   (src drawable)
1021   (src-x int) (src-y int)
1022   (dest-x int) (dest-y int)
1023   ((or width -1) int) ((or height -1) int))
1024
1025 (defbinding draw-image 
1026     (drawable gc image src-x src-y dest-x dest-y &optional width height) nil
1027   (drawable drawable) (gc gc) 
1028   (image image)
1029   (src-x int) (src-y int)
1030   (dest-x int) (dest-y int)
1031   ((or width -1) int) ((or height -1) int))
1032
1033 (defbinding drawable-get-image () image
1034   (drawable drawable)
1035   (x int) (y int)
1036   (width int) (height int))
1037
1038 (defbinding drawable-copy-to-image 
1039     (drawable src-x src-y width height &optional image dest-x dest-y) image
1040   (drawable drawable)
1041   (image (or null image))
1042   (src-x int) (src-y int)
1043   ((if image dest-x 0) int) 
1044   ((if image dest-y 0) int)
1045   (width int) (height int))
1046
1047
1048 ;;; Key values
1049
1050 (defbinding keyval-name () (static string)
1051   (keyval unsigned-int))
1052
1053 (defbinding %keyval-from-name () unsigned-int
1054   (name string))
1055
1056 (defun keyval-from-name (name)
1057   "Returns the keysym value for the given key name or NIL if it is not a valid name."
1058   (let ((keyval (%keyval-from-name name)))
1059     (unless (zerop keyval)
1060       keyval)))
1061
1062 (defbinding keyval-to-upper () unsigned-int
1063   (keyval unsigned-int))
1064
1065 (defbinding keyval-to-lower () unsigned-int
1066   (keyval unsigned-int))
1067
1068 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
1069   (keyval unsigned-int))
1070
1071 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
1072   (keyval unsigned-int))
1073
1074
1075 ;;; Cairo interaction
1076
1077 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
1078 (progn
1079   (defbinding cairo-create () cairo:context
1080     (drawable drawable))
1081
1082   (defmacro with-cairo-context ((cr drawable) &body body)
1083     `(let ((,cr (cairo-create ,drawable)))
1084        (unwind-protect
1085            (progn ,@body)
1086          (invalidate-instance ,cr t))))
1087
1088   (defbinding cairo-set-source-color () nil
1089     (cr cairo:context)
1090     (color color))
1091
1092   (defbinding cairo-set-source-pixbuf (cr pixbuf &optional (x 0.0) (y 0.0)) nil
1093     (cr cairo:context)
1094     (pixbuf pixbuf)
1095     (x double-float)
1096     (y double-float))
1097  
1098   (defbinding cairo-set-source-pixmap (cr pixmap &optional (x 0.0) (y 0.0)) nil
1099     (cr cairo:context)
1100     (pixmap pixmap)
1101     (x double-float)
1102     (y double-float))
1103  
1104   (defbinding cairo-rectangle () nil
1105     (cr cairo:context)
1106     (rectangle rectangle))
1107  
1108   (defbinding cairo-region (cr region) nil
1109     (cr cairo:context)
1110     ((ensure-region region) region))
1111
1112   (defbinding (cairo-surface-get-window "clg_gdk_cairo_surface_get_window") () window
1113     (surface cairo:surface))
1114 )
1115
1116
1117
1118 ;;; Multi-threading support
1119
1120 #+sb-thread
1121 (progn
1122   (defvar *global-lock* nil)
1123   (defvar *recursion-count* 0)
1124
1125   (defun %global-lock-p ()
1126     (eq (sb-thread:mutex-value *global-lock*) sb-thread:*current-thread*))
1127
1128   (defun threads-enter ()
1129     (when *global-lock*
1130       (if (%global-lock-p)
1131           (incf *recursion-count*)
1132         (sb-thread:get-mutex *global-lock*))))
1133     
1134   (defun threads-leave (&optional flush-p)
1135     (when *global-lock*
1136       (assert (%global-lock-p))
1137       (cond
1138        ((zerop *recursion-count*)
1139         (when flush-p
1140           (flush))
1141         (sb-thread:release-mutex *global-lock*))
1142        (t (decf *recursion-count*)))))
1143
1144   (define-callback %enter-fn nil ()
1145     (threads-enter))
1146   
1147   (define-callback %leave-fn nil ()
1148     (threads-leave))
1149   
1150   (defbinding %threads-set-lock-functions (nil) nil
1151     (%enter-fn callback)
1152     (%leave-fn callback))
1153
1154   (defun threads-init ()
1155     (setq *global-lock* (sb-thread:make-mutex :name "global GDK lock"))
1156     (%threads-set-lock-functions))
1157
1158   (defmacro with-global-lock (&body body)
1159     `(progn
1160        (threads-enter)
1161        (unwind-protect
1162            (progn ,@body)
1163          (threads-leave t))))
1164
1165   (defun timeout-add-with-lock (interval function &optional (priority +priority-default+))
1166     (timeout-add interval
1167      #'(lambda () 
1168          (with-global-lock (funcall function)))
1169      priority))
1170
1171   (defun idle-add-with-lock (function &optional (priority +priority-default-idle+))
1172     (idle-add 
1173      #'(lambda () 
1174          (with-global-lock (funcall function)))
1175      priority)))
1176
1177
1178 #-sb-thread
1179 (progn
1180   (defmacro with-global-lock (&body body)
1181     `(progn ,@body))
1182
1183   (defun timeout-add-with-lock (interval function &optional (priority +priority-default+))
1184     (timeout-add interval function priority))
1185
1186   (defun idle-add-with-lock (function &optional (priority +priority-default-idle+))
1187     (idle-add function priority)))
1188
1189