1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2000-2006 Espen S. Johnsen <espen@users.sf.net>
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:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
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.
23 ;; $Id: gdk.lisp,v 1.50 2008-04-21 16:21:07 espen Exp $
30 (defbinding (gdk-init "gdk_parse_args") () nil
31 "Initializes the library without opening the display."
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))))
47 (defbinding %display-open () (or null display)
48 (display-name (or null string)))
50 (defvar *display-aliases* ())
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))
61 (push (cons alias display) *display-aliases*)))
64 (defun display-open (&optional 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))
74 (defbinding %display-get-n-screens () int
77 (defbinding %display-get-screen () screen
81 (defun display-screens (&optional (display (display-get-default)))
83 for i from 0 below (%display-get-n-screens display)
84 collect (%display-get-screen display i)))
86 (defbinding display-get-default-screen
87 (&optional (display (display-get-default))) screen
90 (defbinding display-beep (&optional (display (display-get-default))) nil
93 (defbinding display-sync (&optional (display (display-get-default))) nil
96 (defbinding display-flush (&optional (display (display-get-default))) nil
99 (defbinding display-close (&optional (display (display-get-default))) nil
100 ((ensure-display display t) display))
102 (defbinding flush () nil)
104 (defbinding display-get-event
105 (&optional (display (display-get-default))) (or null event)
108 (defbinding display-peek-event
109 (&optional (display (display-get-default))) (or null event)
112 (defbinding display-put-event
113 (event &optional (display (display-get-default))) event
117 (defbinding (display-connection-number "clg_gdk_connection_number")
118 (&optional (display (display-get-default))) int
121 (defun find-display (name &optional (error-p t))
123 (find name (list-displays) :key #'display-name :test #'string=)
124 (cdr (assoc name *display-aliases* :test #'string=))
126 (error "No such display: ~A" name))))
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=))
134 (defun ensure-display (display &optional existing-only-p)
136 (null (display-get-default))
139 (find-display display existing-only-p)
140 (let* ((new (display-open display))
141 (existing (%find-similar-display new)))
144 (display-add-alias existing display)
152 (defbinding display-get-default () (or null display))
154 (defbinding (display-set-default "gdk_display_manager_set_default_display")
156 ((display-manager) display-manager)
159 (defbinding (list-displays "gdk_display_manager_list_displays") ()
160 (gslist (static display))
161 ((display-manager) display-manager))
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)
167 (defbinding display-get-core-pointer
168 (&optional (display (display-get-default))) device
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
177 (display-get-default)
178 (display-set-default (ensure-display ,current-display))))))
182 (display-set-default ,saved-display))))))
185 ;;; Primitive graphics structures (points, rectangles and regions)
187 (defbinding %rectangle-intersect () boolean
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)
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."
201 (dest rectangle :in/return))
203 (defun ensure-rectangle (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)))))
211 (defbinding %region-new () pointer)
213 (defbinding %region-polygon () pointer
214 (points (vector (inlined point)))
216 (fill-rule fill-rule))
218 (defbinding %region-rectangle () pointer
219 (rectangle rectangle))
221 (defbinding %region-copy () pointer
224 (defbinding %region-destroy () nil
227 (defmethod allocate-foreign ((region region) &key rectangle polygon fill-rule)
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))
235 (defun ensure-region (region)
238 ((or rectangle vector)
239 (make-instance 'region :rectangle (ensure-rectangle region)))
241 (make-instance 'region :polygon region))))
243 (defbinding region-get-clipbox (region &optional (rectangle (make-instance 'rectangle))) nil
245 (rectangle rectangle :in/return))
247 (defbinding %region-get-rectangles () nil
249 (rectangles pointer :out)
250 (n-rectangles int :out))
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)
256 (map-c-vector 'list #'identity location '(inlined rectangle) length :get)
257 (deallocate-memory location))))
259 (defbinding region-empty-p () boolean
262 (defbinding region-equal-p () boolean
266 (defbinding region-point-in-p () boolean
271 (defbinding region-rect-in (region rectangle) overlap-type
273 ((ensure-rectangle rectangle) rectangle))
275 (defbinding region-offset () nil
280 (defbinding region-shrink () nil
285 (defbinding region-intersect (source1 source2) nil
286 ((ensure-region source1) region :in/return)
287 ((ensure-region source2) region))
289 (defbinding region-union (source1 source2) nil
290 ((ensure-region source1) region :in/return)
291 ((ensure-region source2) region))
293 (defbinding region-subtract (source1 source2) nil
294 ((ensure-region source1) region :in/return)
295 ((ensure-region source2) region))
297 (defbinding region-xor (source1 source2) nil
298 ((ensure-region source1) region :in/return)
299 ((ensure-region source2) region))
304 (defbinding (events-pending-p "gdk_events_pending") () boolean)
306 (defbinding event-get () (or null event))
308 (defbinding event-peek () (or null event))
310 (defbinding event-get-graphics-expose () event
313 (defbinding event-put () nil
316 ;(defbinding event-handler-set () ...)
318 (defbinding set-show-events () nil
319 (show-events boolean))
321 (defbinding get-show-events () boolean)
324 ;;; Miscellaneous functions
326 (defbinding screen-width () int
329 (defbinding screen-height () int
332 (defbinding screen-width-mm () int
335 (defbinding screen-height-mm () int
339 (defbinding pointer-grab
340 (window &key owner-events events confine-to cursor time) grab-status
342 (owner-events boolean)
344 (confine-to (or null window))
345 (cursor (or null cursor))
346 ((or time 0) (unsigned 32)))
348 (defbinding (pointer-ungrab "gdk_display_pointer_ungrab")
349 (&optional time (display (display-get-default))) nil
351 ((or time 0) (unsigned 32)))
353 (defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed")
354 (&optional (display (display-get-default))) boolean
357 (defbinding keyboard-grab (window &key owner-events time) grab-status
359 (owner-events boolean)
360 ((or time 0) (unsigned 32)))
362 (defbinding (keyboard-ungrab "gdk_display_keyboard_ungrab")
363 (&optional time (display (display-get-default))) nil
365 ((or time 0) (unsigned 32)))
369 (defbinding atom-intern (atom-name &optional only-if-exists) atom
370 ((string atom-name) string)
371 (only-if-exists boolean))
373 (defbinding atom-name () string
380 (defbinding visual-get-best-depth () int)
382 (defbinding visual-get-best-type () visual-type)
384 (defbinding visual-get-system () visual)
387 (defbinding (%visual-get-best-with-nothing "gdk_visual_get_best") () visual)
389 (defbinding %visual-get-best-with-depth () visual
392 (defbinding %visual-get-best-with-type () visual
395 (defbinding %visual-get-best-with-both () visual
399 (defun visual-get-best (&key depth type)
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))))
406 ;(defbinding query-depths ..)
408 ;(defbinding query-visual-types ..)
410 (defbinding list-visuals () (glist visual))
415 (defbinding window-destroy () nil
418 (defbinding (window-at-pointer "gdk_display_get_window_at_pointer")
419 (&optional (display (display-get-default))) (or null window)
424 (defbinding window-show () nil
427 (defbinding window-show-unraised () nil
430 (defbinding window-hide () nil
433 (defbinding window-is-visible-p () boolean
436 (defbinding window-is-viewable-p () boolean
439 (defbinding window-withdraw () nil
442 (defbinding window-iconify () nil
445 (defbinding window-deiconify () nil
448 (defbinding window-stick () nil
451 (defbinding window-unstick () nil
454 (defbinding window-maximize () nil
457 (defbinding window-unmaximize () nil
460 (defbinding window-fullscreen () nil
463 (defbinding window-unfullscreen () nil
466 (defbinding window-set-keep-above () nil
470 (defbinding window-set-keep-below () nil
474 (defbinding window-move () nil
479 (defbinding window-resize () nil
484 (defbinding window-move-resize () nil
491 (defbinding window-scroll () nil
496 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
497 (defbinding window-move-region (window region dx dy) nil
499 ((ensure-region region) region)
503 (defbinding window-reparent () nil
509 (defbinding window-clear () nil
512 (defbinding %window-clear-area () nil
514 (x int) (y int) (width int) (height int))
516 (defbinding %window-clear-area-e () nil
518 (x int) (y int) (width int) (height int))
520 (defun window-clear-area (window x y width height &optional expose)
522 (%window-clear-area-e window x y width height)
523 (%window-clear-area window x y width height)))
525 (defbinding window-raise () nil
528 (defbinding window-lower () nil
531 (defbinding window-focus () nil
533 (timestamp unsigned-int))
535 (defbinding window-register-dnd () nil
538 (defbinding window-begin-resize-drag () nil
544 (timestamp unsigned-int))
546 (defbinding window-begin-move-drag () nil
551 (timestamp unsigned-int))
553 ;; Probably not needed
554 ;; (defbinding window-constrain-size () nil ..
556 (defbinding window-begin-paint-region (window region) nil
558 ((ensure-region region) region))
560 (defbinding window-end-paint () nil
563 (defmacro with-window-paint ((window region) &body body)
565 (window-begin-paint-region ,window ,region)
568 (window-end-paint ,window))))
570 ;; TODO: create wrapper function and use gdk_window_invalidate_maybe_recurse
571 ;; if last arg is a function
572 (defbinding window-invalidate-region (window region invalidate-children-p) nil
574 ((ensure-region region) region)
575 (invalidate-children-p boolean))
577 (defbinding window-get-update-area () region
580 (defbinding window-freeze-updates () nil
583 (defbinding window-thaw-updates () nil
586 (defbinding window-process-all-updates () nil)
588 (defbinding window-process-updates () nil
590 (update-children-p boolean))
592 (defbinding window-set-debug-updates () nil
595 (defbinding window-enable-synchronized-configure () nil
598 (defbinding window-configure-finished () nil
601 ;; Deprecated, use gobject user data mechanism
602 (defbinding window-set-user-data () nil
606 (defbinding window-set-override-redirect () nil
608 (override-redirect-p boolean))
610 (defbinding window-set-accept-focus () nil
612 (accept-focus-p boolean))
614 (defbinding window-set-focus-on-map () nil
616 (focus-on-map-p boolean))
619 ; (defbinding window-add-filter () nil
620 ; (defbinding window-remove-filter () nil
622 ;; New code should use window-shape-combine
623 (defbinding window-shape-combine-mask () nil
629 (defbinding %window-shape-combine-region () nil
631 (region (or null region))
635 (defun window-shape-combine (window shape offset-x offset-y)
637 (null (%window-shape-combine-region window nil 0 0))
638 (region (%window-shape-combine-region window shape offset-x offset-y))
639 (bitmap (window-shape-combine-mask window shape offset-x offset-y))))
641 (defbinding window-set-child-shapes () nil
644 (defbinding window-merge-child-shapes () nil
647 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
649 (defbinding %window-input-shape-combine-mask () nil
655 (defbinding %window-input-shape-combine-region () nil
657 (region (or null region))
661 (defun window-input-shape-combine (window shape x y)
663 (null (%window-input-shape-combine-region window nil 0 0))
664 (region (%window-input-shape-combine-region window shape x y))
665 (bitmap (%window-input-shape-combine-mask window shape x y))))
667 (defbinding window-set-child-input-shapes () nil
670 (defbinding window-merge-child-input-shapes () nil
673 (defbinding window-set-static-gravities () boolean
675 (use-static-p boolean))
677 (defbinding window-set-title () nil
681 (defbinding window-set-background () nil
685 (defbinding window-set-back-pixmap (window pixmap &optional parent-relative-p) nil
687 (pixmap (or null pixmap))
688 (parent-relative-p boolean))
690 (defbinding window-set-cursor () nil
692 (cursor (or null cursor)))
694 (defbinding window-get-geometry () nil
702 ;(defbinding window-set-geometry-hints () nil
704 (defbinding window-set-icon-list () nil
706 (icons (glist pixbufs)))
708 (defbinding window-set-skip-taskbar-hint () nil
710 (skip-taskbar-p boolean))
712 (defbinding window-set-skip-pager-hint () nil
714 (skip-pager-p boolean))
716 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
717 (defbinding window-set-urgency-hint () nil
721 (defbinding window-get-position () nil
726 (defbinding window-get-root-origin () nil
731 (defbinding window-get-frame-extents (window &optional (extents (make-instance 'rect))) nil
733 (extents rectangle :in/return))
735 (defbinding window-get-origin () nil ; this may not work as
736 (window window) ; an int is actually returned
740 (defbinding window-get-pointer () (or null window)
744 (mask modifier-type :out))
746 ;(defbinding window-set-icon () nil
748 (defbinding window-set-icon-name () nil
752 (defbinding window-set-transient-for () nil
756 (defbinding window-set-role () nil
760 (defbinding %window-get-decorations () boolean
762 (decorations wm-decoration :out))
764 (defun %window-decorations-getter (window)
765 (nth-value 1 (%window-get-decorations window)))
767 (defun %window-decorations-boundp (window)
768 (%window-get-decorations window))
770 (defbinding %window-get-toplevels () (glist window))
772 (defun window-get-toplevels (&optional screen)
774 (error "Not implemented")
775 (%window-get-toplevels)))
777 (defbinding %get-default-root-window () window)
779 (defun get-root-window (&optional display)
781 (error "Not implemented")
782 (%get-default-root-window)))
790 (defbinding drag-status () nil
791 (context drag-context)
793 (time (unsigned 32)))
802 (defbinding rgb-init () nil)
809 (defmethod allocate-foreign ((cursor cursor) &key source mask fg bg
810 (x 0) (y 0) (display (display-get-default)))
812 (keyword (%cursor-new-for-display display source))
813 (pixbuf (%cursor-new-from-pixbuf display source x y))
814 (pixmap (%cursor-new-from-pixmap source mask
815 (or fg (ensure-color #(0.0 0.0 0.0)))
816 (or bg (ensure-color #(1.0 1.0 1.0))) x y))
817 (pathname (%cursor-new-from-pixbuf display (pixbuf-load source) x y))))
819 (defun ensure-cursor (cursor &rest args)
820 (if (typep cursor 'cursor)
822 (apply #'make-instance 'cursor :source cursor args)))
824 (defbinding %cursor-new-for-display () pointer
826 (cursor-type cursor-type))
828 (defbinding %cursor-new-from-pixmap () pointer
835 (defbinding %cursor-new-from-pixbuf () pointer
840 (defbinding %cursor-ref () pointer
843 (defbinding %cursor-unref () nil
849 (defbinding %pixmap-new () pointer
850 (window (or null window))
855 (defmethod allocate-foreign ((pximap pixmap) &key width height depth window)
856 (%pixmap-new window (or width (drawable-width window)) (or height (drawable-height window)) (or depth -1)))
858 (defun pixmap-new (width height depth &key window)
859 (warn "PIXMAP-NEW is deprecated, use (make-instance 'pixmap ...) instead")
860 (make-instance 'pixmap :width width :height height :depth depth :window window))
862 (defbinding %pixmap-colormap-create-from-xpm () pixmap
863 (window (or null window))
864 (colormap (or null colormap))
866 (color (or null color))
869 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
870 (window (or null window))
871 (colormap (or null colormap))
873 (color (or null color))
874 (data (vector string)))
876 ;; Deprecated, use pixbufs instead
877 (defun pixmap-create (source &key color window colormap)
879 (if (not (or window colormap))
882 (multiple-value-bind (pixmap mask)
884 ((or string pathname)
885 (%pixmap-colormap-create-from-xpm window colormap color source))
887 (%pixmap-colormap-create-from-xpm-d window colormap color source)))
888 (values pixmap mask))))
893 (defbinding colormap-get-system () colormap)
895 (defbinding %color-copy () pointer
898 (defmethod allocate-foreign ((color color) &rest initargs)
899 (declare (ignore color initargs))
900 ;; Color structs are allocated as memory chunks by gdk, and since
901 ;; there is no gdk_color_new we have to use this hack to get a new
903 (with-memory (location #.(foreign-size (find-class 'color)))
904 (%color-copy location)))
906 (defun %scale-value (value)
909 (float (truncate (* value 65535)))))
911 (defmethod initialize-instance ((color color) &key (red 0.0) (green 0.0) (blue 0.0))
913 (with-slots ((%red red) (%green green) (%blue blue)) color
915 %red (%scale-value red)
916 %green (%scale-value green)
917 %blue (%scale-value blue))))
919 (defbinding %color-parse () boolean
921 (color color :in/return))
923 (defun color-parse (spec &optional (color (make-instance 'color)))
924 (multiple-value-bind (succeeded-p color) (%color-parse spec color)
927 (error "Parsing color specification ~S failed." spec))))
929 (defun ensure-color (color)
933 (string (color-parse color))
935 (make-instance 'color
936 :red (svref color 0) :green (svref color 1) :blue (svref color 2)))))
940 ;;; Drawable -- all the draw- functions are deprecated and will be
941 ;;; removed, use cairo for drawing instead.
943 (defbinding drawable-get-size () nil
948 (defbinding (drawable-width "gdk_drawable_get_size") () nil
953 (defbinding (drawable-height "gdk_drawable_get_size") () nil
958 ;; (defbinding drawable-get-clip-region () region
959 ;; (drawable drawable))
961 ;; (defbinding drawable-get-visible-region () region
962 ;; (drawable drawable))
964 (defbinding draw-point () nil
965 (drawable drawable) (gc gc)
968 (defbinding %draw-points () nil
969 (drawable drawable) (gc gc)
973 (defbinding draw-line () nil
974 (drawable drawable) (gc gc)
978 (defbinding draw-pixbuf
979 (drawable gc pixbuf src-x src-y dest-x dest-y &optional
980 width height (dither :none) (x-dither 0) (y-dither 0)) nil
981 (drawable drawable) (gc (or null gc))
983 (src-x int) (src-y int)
984 (dest-x int) (dest-y int)
985 ((or width -1) int) ((or height -1) int)
987 (x-dither int) (y-dither int))
989 (defbinding draw-rectangle () nil
990 (drawable drawable) (gc gc)
993 (width int) (height int))
995 (defbinding draw-arc () nil
996 (drawable drawable) (gc gc)
999 (width int) (height int)
1000 (angle1 int) (angle2 int))
1002 (defbinding %draw-layout () nil
1003 (drawable drawable) (gc gc)
1005 (layout pango:layout))
1007 (defbinding %draw-layout-with-colors () nil
1008 (drawable drawable) (gc gc)
1010 (layout pango:layout)
1011 (foreground (or null color))
1012 (background (or null color)))
1014 (defun draw-layout (drawable gc x y layout &optional foreground background)
1015 (if (or foreground background)
1016 (%draw-layout-with-colors drawable gc x y layout foreground background)
1017 (%draw-layout drawable gc x y layout)))
1019 (defbinding draw-drawable
1020 (drawable gc src src-x src-y dest-x dest-y &optional width height) nil
1021 (drawable drawable) (gc gc)
1023 (src-x int) (src-y int)
1024 (dest-x int) (dest-y int)
1025 ((or width -1) int) ((or height -1) int))
1027 (defbinding draw-image
1028 (drawable gc image src-x src-y dest-x dest-y &optional width height) nil
1029 (drawable drawable) (gc gc)
1031 (src-x int) (src-y int)
1032 (dest-x int) (dest-y int)
1033 ((or width -1) int) ((or height -1) int))
1035 (defbinding drawable-get-image () image
1038 (width int) (height int))
1040 (defbinding drawable-copy-to-image
1041 (drawable src-x src-y width height &optional image dest-x dest-y) image
1043 (image (or null image))
1044 (src-x int) (src-y int)
1045 ((if image dest-x 0) int)
1046 ((if image dest-y 0) int)
1047 (width int) (height int))
1052 (defbinding keyval-name () (static string)
1053 (keyval unsigned-int))
1055 (defbinding %keyval-from-name () unsigned-int
1058 (defun keyval-from-name (name)
1059 "Returns the keysym value for the given key name or NIL if it is not a valid name."
1060 (let ((keyval (%keyval-from-name name)))
1061 (unless (zerop keyval)
1064 (defbinding keyval-to-upper () unsigned-int
1065 (keyval unsigned-int))
1067 (defbinding keyval-to-lower () unsigned-int
1068 (keyval unsigned-int))
1070 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
1071 (keyval unsigned-int))
1073 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
1074 (keyval unsigned-int))
1077 ;;; Cairo interaction
1079 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
1081 (defbinding cairo-create () cairo:context
1082 (drawable drawable))
1084 (defmacro with-cairo-context ((cr drawable) &body body)
1085 `(let ((,cr (cairo-create ,drawable)))
1088 (invalidate-instance ,cr t))))
1090 (defbinding cairo-set-source-color () nil
1094 (defbinding cairo-set-source-pixbuf (cr pixbuf &optional (x 0.0) (y 0.0)) nil
1100 (defbinding cairo-set-source-pixmap (cr pixmap &optional (x 0.0) (y 0.0)) nil
1106 (defbinding cairo-rectangle () nil
1108 (rectangle rectangle))
1110 (defbinding cairo-region (cr region) nil
1112 ((ensure-region region) region))
1114 (defbinding (cairo-surface-get-window "clg_gdk_cairo_surface_get_window") () window
1115 (surface cairo:surface))
1120 ;;; Multi-threading support
1124 (defvar *global-lock* nil)
1125 (defvar *recursion-count* 0)
1127 (defun %global-lock-p ()
1128 (eq (sb-thread:mutex-value *global-lock*) sb-thread:*current-thread*))
1130 (defun threads-enter ()
1132 (if (%global-lock-p)
1133 (incf *recursion-count*)
1134 (sb-thread:get-mutex *global-lock*))))
1136 (defun threads-leave (&optional flush-p)
1138 (assert (%global-lock-p))
1140 ((zerop *recursion-count*)
1143 (sb-thread:release-mutex *global-lock*))
1144 (t (decf *recursion-count*)))))
1146 (define-callback %enter-fn nil ()
1149 (define-callback %leave-fn nil ()
1152 (defbinding %threads-set-lock-functions (nil) nil
1153 (%enter-fn callback)
1154 (%leave-fn callback))
1156 (defun threads-init ()
1157 (setq *global-lock* (sb-thread:make-mutex :name "global GDK lock"))
1158 (%threads-set-lock-functions))
1160 (defmacro with-global-lock (&body body)
1165 (threads-leave t))))
1167 (defun timeout-add-with-lock (interval function &optional (priority +priority-default+))
1168 (timeout-add interval
1170 (with-global-lock (funcall function)))
1173 (defun idle-add-with-lock (function &optional (priority +priority-default-idle+))
1176 (with-global-lock (funcall function)))
1182 (defmacro with-global-lock (&body body)
1185 (defun timeout-add-with-lock (interval function &optional (priority +priority-default+))
1186 (timeout-add interval function priority))
1188 (defun idle-add-with-lock (function &optional (priority +priority-default-idle+))
1189 (idle-add function priority)))