<commit_before>;; Common Lisp bindings for GTK+ v2.x
;; Copyright 1999-2006 <NAME> <<EMAIL>>
;;
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

;; $Id: gtk.lisp,v 1.81 2007-07-12 13:55:59 espen Exp $


(in-package "GTK")

;;; Gtk version

(defbinding check-version () (copy-of string)
  (required-major unsigned-int)
  (required-minor unsigned-int)
  (required-micro unsigned-int))

(defbinding query-version () nil
  (major unsigned-int :out)
  (minor unsigned-int :out)
  (micro unsigned-int :out))

(defun gtk-version ()
  (multiple-value-bind (major minor micro)
      (query-version)
    (if (zerop micro)
	(format nil "Gtk+ v~A.~A" major minor) 
      (format nil "Gtk+ v~A.~A.~A" major minor micro))))

(defun clg-version ()
  "clg 0.93")


;;;; Initalization and display handling

(defparameter *event-poll-interval* 10000) ; in microseconds


(defbinding (gtk-init "gtk_parse_args") () boolean
  "Initializes the library without opening the display."
  (nil null)
  (nil null))

(defun clg-init (&optional display multi-threading-p)
  "Initializes the system and starts event handling."
  (unless (gdk:display-get-default)
    #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
    (progn
      #+sbcl(sb-int:set-floating-point-modes :traps nil) 
      #+cmu(ext:set-floating-point-modes :traps nil))

     (gdk:gdk-init)
     (unless (gtk-init)
       (error "Initialization of GTK+ failed."))

    (if (not multi-threading-p) 
	(%init-async-event-handling display)
      #+sb-thread(%init-multi-threaded-event-handling display)
      #-sb-thread(error "Multi threading not supported on this platform")))
  (gdk:ensure-display display t))

(defun clg-init-with-threading (&optional display)
  (clg-init display t))


#?(sbcl>= 1 0 6)
;; A very minimal implementation of CLISP's socket-status
(defun socket-status (socket seconds microseconds)
  (sb-alien:with-alien ((read-fds (sb-alien:struct sb-unix:fd-set)))
    (let ((fd (sb-sys:fd-stream-fd (car socket))))
      (sb-unix:fd-zero read-fds)
      (sb-unix:fd-set fd read-fds)

      (let ((num-fds-changed
	     (sb-unix:unix-fast-select
	      (1+ fd) (sb-alien:addr read-fds) nil nil 
	      seconds microseconds)))
	(unless (or (not num-fds-changed) (zerop num-fds-changed))
	  (if (peek-char nil (car socket) nil)
	      :input
	    :eof))))))

(defun %init-async-event-handling (display)
  (let ((style #?(or (featurep :cmu) (sbcl< 1 0 6)) :fd-handler
	       #?-(or (featurep :cmu) (sbcl< 1 0 6)) nil))
    (when (and 
	   (find-package "SWANK")
	   (not (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) style)))
      (error "When running clg in Slime, the communication style ~A must be used in combination with asynchronous event handling on this platform. See the README file and <http://common-lisp.net/project/slime/doc/html/slime_45.html> for more information." style)))

  #?(or (featurep :cmu) (sbcl< 1 0 6))
  (progn
    (signal-connect (gdk:display-manager) 'display-opened
     #'(lambda (display)
	 (let ((fd (gdk:display-connection-number display)))
	   (unless (< fd 0)
	     (let ((handler (add-fd-handler 
			     (gdk:display-connection-number display) 
			     :input #'main-iterate-all)))
	       (signal-connect display 'closed
		#'(lambda (is-error-p)
		    (declare (ignore is-error-p))
		    (remove-fd-handler handler))))))))
    (setq *periodic-polling-function* #'main-iterate-all)
    (setq *max-event-to-sec* 0)
    (setq *max-event-to-usec* *event-poll-interval*))
  
  #+(and clisp readline)
  ;; Readline will call the event hook at most ten times per second
  (setf readline:event-hook #'main-iterate-all)
  
  #?-(or (featurep :cmu) (sbcl< 1 0 6))
  ;; When running in Slime we need to hook into the Swank server
  ;; to handle events asynchronously.
  (if (find-package "SWANK")
      (let ((read-from-emacs (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK")))
	    (stream (funcall (find-symbol "CONNECTION.SOCKET-IO" "SWANK") (symbol-value (find-symbol "*EMACS-CONNECTION*" "SWANK")))))
	(setf (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK"))
	 #'(lambda ()
	     (loop
	      (case (socket-status (cons stream :input) 0 *event-poll-interval*)
		((:input :eof) (return (funcall read-from-emacs)))
		(otherwise (main-iterate-all)))))))
    #-(and clisp readline)
    (warn "Asynchronous event handling not supported on this platform. An explicit main loop has to be started."))

  (gdk:display-open display))

#+sb-thread
(progn
  (defvar *main-thread* nil)

  ;; Hopefully, when threading support is added to the Win32 port of
  ;; SBCL in the future, this will work just out of the box.
  #+win32
  (let ((done (sb-thread:make-waitqueue))
	(functions ())
	(results ()))

    ;; In Win32 all GDK calls have to be made from the main loop
    ;; thread, so we add a timeout function which will poll for code and
    ;; execute it.

    (defun funcall-in-main (function)
      (if (or 
	   (not *main-thread*)
	   (eq sb-thread:*current-thread* *main-thread*))
	  (funcall function)
	(gdk:with-global-lock
	  (push function functions)
 	  (sb-thread:condition-wait done gdk:*global-lock*)
 	  (pop results))))

    ;; Will lock REPL on error, need to be fixed!
    (defun %funcall-in-main-poll ()
      (when functions
	(loop
	 for n from 0
	 while functions 
	 do (push (funcall (pop functions)) results)
	 finally (sb-thread:condition-notify done n)))
      t))

  (defmacro within-main-loop (&body body)
    #-win32 `(gdk:with-global-lock ,@body)
    #+win32 `(funcall-in-main #'(lambda () ,@body)))
  
  (defun %init-multi-threaded-event-handling (display)
    (when (and 
	   (find-package "SWANK")
	   (not (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) :spawn)))
      (error "When running clg in Slime, the communication style :spawn must be used in combination with multi threaded event handling. See the README file and <http://common-lisp.net/project/slime/doc/html/slime_45.html> for more information."))
    (let ((main-running (sb-thread:make-waitqueue)))
      (gdk:with-global-lock
       (setf *main-thread*
        (sb-thread:make-thread 
	 #'(lambda () 
	     (gdk:threads-init)	 
	     (gdk:with-global-lock 
	       (gdk:display-open display)
	       #+win32(gdk:timeout-add-with-lock (/ *event-poll-interval* 1000)
		       #'%funcall-in-main-poll)
	       (sb-thread:condition-notify main-running)
	       (main)))
	 :name "gtk event loop"))
	(sb-thread:condition-wait main-running gdk:*global-lock*)))
  
    ;; We need to hook into the Swank server to protect calls to GDK properly.
    ;; This will *only* protect code entered directly in the REPL.
    (when (find-package "SWANK")
      (push #'(lambda (form) 
		(within-main-loop (eval form)))
       swank::*slime-repl-eval-hooks*))))

#-sb-thread
(defmacro within-main-loop (&body body)
  `(progn ,@body))



;;; Generic functions 

(defgeneric add-to-radio-group (item1 item2))
(defgeneric activate-radio-widget (item))
(defgeneric (setf tool-item-tip-text) (tip-text tool-item))
(defgeneric (setf tool-item-tip-private) (tip-private tool-item))



;;; Misc

(defbinding grab-add () nil
  (widget widget))

(defbinding grab-get-current () widget)

(defbinding grab-remove () nil
  (widget widget))

(defbinding get-default-language () (copy-of pango:language))


;;; About dialog

#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
(progn
  (define-callback-marshal %about-dialog-activate-link-callback nil
    (about-dialog (link string)))

  (defbinding about-dialog-set-email-hook (function) nil
    (%about-dialog-activate-link-callback callback)
    ((register-callback-function function) unsigned-int)
    (user-data-destroy-callback callback))
  
  (defbinding about-dialog-set-url-hook (function) nil
    (%about-dialog-activate-link-callback callback)
    ((register-callback-function function) unsigned-int)
    (user-data-destroy-callback callback)))


;;; Acccel group

(defbinding %accel-group-connect () nil
  (accel-group accel-group)
  (key unsigned-int)
  (modifiers gdk:modifier-type)
  (flags accel-flags)
  (gclosure gclosure))

(defun accel-group-connect (group accelerator function &optional flags)
  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
    (let ((gclosure (make-callback-closure function)))
      (%accel-group-connect group key modifiers flags gclosure)
      gclosure)))

(defbinding accel-group-connect-by-path (group path function) nil
  (group accel-group)
  (path string)
  ((make-callback-closure function) gclosure :in/return))

(defbinding %accel-group-disconnect (group gclosure) boolean
  (group accel-group)
  (gclosure gclosure))

(defbinding %accel-group-disconnect-key () boolean
  (group accel-group)
  (key unsigned-int)
  (modifiers gdk:modifier-type))

(defun accel-group-disconnect (group accelerator)
  (etypecase accelerator
    (gclosure (%accel-group-disconnect group accelerator))
    (string 
     (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
       (%accel-group-disconnect-key group key modifiers)))))

(defbinding %accel-group-query () (copy-of (vector (inlined accel-group-entry) n))
  (accel-group accel-group)
  (key unsigned-int)
  (modifiers gdk:modifier-type)
  (n int :out))

(defun accel-group-query (accel-group accelerator)
  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
    (%accel-group-query accel-group key modifiers)))

(defbinding %accel-group-activate () boolean
  (accel-group accel-group)
  (acceleratable gobject)
  (key unsigned-int)
  (modifiers gdk:modifier-type))

(defun accel-group-activate (accel-group acceleratable accelerator)
  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
    (%accel-group-activate accel-group acceleratable key modifiers)))

(defbinding accel-group-lock () nil
  (accel-group accel-group))

(defbinding accel-group-unlock () nil
  (accel-group accel-group))

(defbinding accel-group-from-accel-closure () accel-group
  (closure gclosure))

(defbinding %accel-groups-activate () boolean
  (object gobject)
  (key unsigned-int)
  (modifiers gdk:modifier-type))

(defun accel-groups-activate (object accelerator)
  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
    (%accel-groups-activate object key modifiers)))

(defbinding accel-groups-from-object () (gslist accel-group)
  (object gobject))

(defbinding accelerator-valid-p (key &optional modifiers) boolean
  (key unsigned-int)
  (modifiers gdk:modifier-type))

(defbinding %accelerator-parse () nil
  (accelerator string)
  (key unsigned-int :out)
  (modifiers gdk:modifier-type :out))

(defgeneric parse-accelerator (accelerator))

(defmethod parse-accelerator ((accelerator string))
  (multiple-value-bind (key modifiers) (%accelerator-parse accelerator)
    (if (zerop key)
	(error "Invalid accelerator: ~A" accelerator)
      (values key modifiers))))

(defmethod parse-accelerator ((accelerator cons))
  (destructuring-bind (key modifiers) accelerator
    (values
     (etypecase key
       (integer key)
       (string
	(or 
	 (gdk:keyval-from-name key)
	 (error "Invalid key name: ~A" key)))
       (character (parse-accelerator key)))
     modifiers)))

(defmethod parse-accelerator ((key integer))
  key)

(defmethod parse-accelerator ((key character))
  (or
   (gdk:keyval-from-name (string key))
   (error "Invalid key name: ~A" key)))


(defbinding accelerator-name () string
  (key unsigned-int)
  (modifiers gdk:modifier-type))

#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
(defbinding accelerator-get-label () string
  (key unsigned-int)
  (modifiers gdk:modifier-type))

(defbinding %accelerator-set-default-mod-mask () nil
  (default-modifiers gdk:modifier-type))

(defun (setf accelerator-default-modifier-mask) (default-modifiers)
  (%accelerator-set-default-mod-mask default-modifiers))

(defbinding (accelerator-default-modifier-mask "gtk_accelerator_get_default_mod_mask") () gdk:modifier-type)


;;; Acccel label

(defbinding accel-label-get-accel-width () unsigned-int
  (accel-label accel-label))

(defbinding accel-label-refetch () boolean
  (accel-label accel-label))



;;; Accel map

(defbinding %accel-map-add-entry () nil
  (path string)
  (key unsigned-int)
  (modifiers gdk:modifier-type))

(defun accel-map-add-entry (path accelerator)
  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
    (%accel-map-add-entry path key modifiers)))

(defbinding %accel-map-lookup-entry () boolean
  (path string)
  ((make-instance 'accel-key) accel-key :in/return))

(defun accel-map-lookup-entry (path)
  (multiple-value-bind (found-p accel-key) (%accel-map-lookup-entry path)
    (when found-p
      (values 
       (slot-value accel-key 'key)
       (slot-value accel-key 'modifiers)
       (slot-value accel-key 'flags)))))

(defbinding %accel-map-change-entry () boolean
  (path string)
  (key unsigned-int)
  (modifiers gdk:modifier-type)
  (replace boolean))

(defun accel-map-change-entry (path accelerator &optional replace)
  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
    (%accel-map-change-entry path key modifiers replace)))

(defbinding accel-map-load () nil
  (filename pathname))

(defbinding accel-map-save () nil
  (filename pathname))

(define-callback-marshal %accel-map-foreach-callback nil
  ((accel-path string) (key unsigned-int) 
   (modifiers gdk:modifier-type) (changed boolean)) :callback-id :first)

(defbinding %accel-map-foreach (callback-id) nil
  (callback-id unsigned-int)
  (%accel-map-foreach-callback callback))

(defbinding %accel-map-foreach-unfiltered (callback-id) nil
  (callback-id unsigned-int)
  (%accel-map-foreach-callback callback))

(defun accel-map-foreach (function &optional (filter-p t))
  (with-callback-function (id function)
    (if filter-p			  
	(%accel-map-foreach id)
      (%accel-map-foreach-unfiltered id))))

(defbinding accel-map-add-filter () nil
  (filter string))

(defbinding accel-map-get () accel-map)

(defbinding accel-map-lock-path () nil
  (path string))

(defbinding accel-map-unlock-path () nil
  (path string))



;;; Accessibility

(defbinding accessible-connect-widget-destroyed () nil
  (accessible accessible))


;;; Adjustment

(defmethod initialize-instance ((adjustment adjustment) &key value)
  (prog1
      (call-next-method)
    ;; we need to make sure that the value is set last, otherwise it
    ;; may be outside current limits and ignored
    (when value
      (setf (slot-value adjustment 'value) value))))


(defbinding adjustment-changed () nil
  (adjustment adjustment))

(defbinding adjustment-value-changed () nil
  (adjustment adjustment))

(defbinding adjustment-clamp-page () nil
  (adjustment adjustment)
  (lower single-float)
  (upper single-float))


;;; Alignment

(defbinding alignment-set () nil
  (alognment alignment)
  (x-align single-float)
  (y-align single-float)
  (x-scale single-float)
  (y-scale single-float))

(defbinding alignment-get-padding () nil
  (alognment alignment)
  (top unsigned-int :out)
  (bottom unsigned-int :out)
  (left unsigned-int :out)
  (right unsigned-int :out))

(defbinding alignment-set-padding () nil
  (alognment alignment)
  (top unsigned-int)
  (bottom unsigned-int)
  (left unsigned-int)
  (right unsigned-int))


;;; Assistant

#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
(progn
  (defbinding assistant-get-nth-page () widget
    (assistant assistant)
    (page-num int))
  
  (defbinding %assistant-insert-page () int
    (assistant assistant)
    (page widget)
    (pos int))

  (defun assistant-insert-page (assistant page position &rest child-args)    
    (let ((pos (case position
		 (:first 0)
		 (:last -1)
		 (t position))))
      (prog1
	  (%assistant-insert-page assistant page pos)
	(init-child-slots assistant page child-args))))
  
  (defun assistant-append-page (assistant page &rest child-args)
    (apply #'assistant-insert-page assistant page :last child-args))
  
  (defun assistant-prepend-page (assistant page &rest child-args)
    (apply #'assistant-insert-page assistant page :first child-args))

  (define-callback-marshal %assistant-page-func-callback int
    ((current-page int)))

  (defbinding assistant-set-forward-func (assistant function) nil
    (assistant assistant)
    (%assistant-page-func-callback callback)
    ((register-callback-function function) pointer-data)<commit_msg>Fixed wrong foreign function name<commit_after>;; Common Lisp bindings for GTK+ v2.x
;; Copyright 1999-2006 <NAME> <<EMAIL>>
;;
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

;; $Id: gtk.lisp,v 1.82 2007-08-20 10:54:38 espen Exp $


(in-package "GTK")

;;; Gtk version

(defbinding check-version () (copy-of string)
  (required-major unsigned-int)
  (required-minor unsigned-int)
  (required-micro unsigned-int))

(defbinding query-version () nil
  (major unsigned-int :out)
  (minor unsigned-int :out)
  (micro unsigned-int :out))

(defun gtk-version ()
  (multiple-value-bind (major minor micro)
      (query-version)
    (if (zerop micro)
	(format nil "Gtk+ v~A.~A" major minor) 
      (format nil "Gtk+ v~A.~A.~A" major minor micro))))

(defun clg-version ()
  "clg 0.93")


;;;; Initalization and display handling

(defparameter *event-poll-interval* 10000) ; in microseconds


(defbinding (gtk-init "gtk_parse_args") () boolean
  "Initializes the library without opening the display."
  (nil null)
  (nil null))

(defun clg-init (&optional display multi-threading-p)
  "Initializes the system and starts event handling."
  (unless (gdk:display-get-default)
    #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
    (progn
      #+sbcl(sb-int:set-floating-point-modes :traps nil) 
      #+cmu(ext:set-floating-point-modes :traps nil))

     (gdk:gdk-init)
     (unless (gtk-init)
       (error "Initialization of GTK+ failed."))

    (if (not multi-threading-p) 
	(%init-async-event-handling display)
      #+sb-thread(%init-multi-threaded-event-handling display)
      #-sb-thread(error "Multi threading not supported on this platform")))
  (gdk:ensure-display display t))

(defun clg-init-with-threading (&optional display)
  (clg-init display t))


#?(sbcl>= 1 0 6)
;; A very minimal implementation of CLISP's socket-status
(defun socket-status (socket seconds microseconds)
  (sb-alien:with-alien ((read-fds (sb-alien:struct sb-unix:fd-set)))
    (let ((fd (sb-sys:fd-stream-fd (car socket))))
      (sb-unix:fd-zero read-fds)
      (sb-unix:fd-set fd read-fds)

      (let ((num-fds-changed
	     (sb-unix:unix-fast-select
	      (1+ fd) (sb-alien:addr read-fds) nil nil 
	      seconds microseconds)))
	(unless (or (not num-fds-changed) (zerop num-fds-changed))
	  (if (peek-char nil (car socket) nil)
	      :input
	    :eof))))))

(defun %init-async-event-handling (display)
  (let ((style #?(or (featurep :cmu) (sbcl< 1 0 6)) :fd-handler
	       #?-(or (featurep :cmu) (sbcl< 1 0 6)) nil))
    (when (and 
	   (find-package "SWANK")
	   (not (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) style)))
      (error "When running clg in Slime, the communication style ~A must be used in combination with asynchronous event handling on this platform. See the README file and <http://common-lisp.net/project/slime/doc/html/slime_45.html> for more information." style)))

  #?(or (featurep :cmu) (sbcl< 1 0 6))
  (progn
    (signal-connect (gdk:display-manager) 'display-opened
     #'(lambda (display)
	 (let ((fd (gdk:display-connection-number display)))
	   (unless (< fd 0)
	     (let ((handler (add-fd-handler 
			     (gdk:display-connection-number display) 
			     :input #'main-iterate-all)))
	       (signal-connect display 'closed
		#'(lambda (is-error-p)
		    (declare (ignore is-error-p))
		    (remove-fd-handler handler))))))))
    (setq *periodic-polling-function* #'main-iterate-all)
    (setq *max-event-to-sec* 0)
    (setq *max-event-to-usec* *event-poll-interval*))
  
  #+(and clisp readline)
  ;; Readline will call the event hook at most ten times per second
  (setf readline:event-hook #'main-iterate-all)
  
  #?-(or (featurep :cmu) (sbcl< 1 0 6))
  ;; When running in Slime we need to hook into the Swank server
  ;; to handle events asynchronously.
  (if (find-package "SWANK")
      (let ((read-from-emacs (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK")))
	    (stream (funcall (find-symbol "CONNECTION.SOCKET-IO" "SWANK") (symbol-value (find-symbol "*EMACS-CONNECTION*" "SWANK")))))
	(setf (symbol-function (find-symbol "READ-FROM-EMACS" "SWANK"))
	 #'(lambda ()
	     (loop
	      (case (socket-status (cons stream :input) 0 *event-poll-interval*)
		((:input :eof) (return (funcall read-from-emacs)))
		(otherwise (main-iterate-all)))))))
    #-(and clisp readline)
    (warn "Asynchronous event handling not supported on this platform. An explicit main loop has to be started."))

  (gdk:display-open display))

#+sb-thread
(progn
  (defvar *main-thread* nil)

  ;; Hopefully, when threading support is added to the Win32 port of
  ;; SBCL in the future, this will work just out of the box.
  #+win32
  (let ((done (sb-thread:make-waitqueue))
	(functions ())
	(results ()))

    ;; In Win32 all GDK calls have to be made from the main loop
    ;; thread, so we add a timeout function which will poll for code and
    ;; execute it.

    (defun funcall-in-main (function)
      (if (or 
	   (not *main-thread*)
	   (eq sb-thread:*current-thread* *main-thread*))
	  (funcall function)
	(gdk:with-global-lock
	  (push function functions)
 	  (sb-thread:condition-wait done gdk:*global-lock*)
 	  (pop results))))

    ;; Will lock REPL on error, need to be fixed!
    (defun %funcall-in-main-poll ()
      (when functions
	(loop
	 for n from 0
	 while functions 
	 do (push (funcall (pop functions)) results)
	 finally (sb-thread:condition-notify done n)))
      t))

  (defmacro within-main-loop (&body body)
    #-win32 `(gdk:with-global-lock ,@body)
    #+win32 `(funcall-in-main #'(lambda () ,@body)))
  
  (defun %init-multi-threaded-event-handling (display)
    (when (and 
	   (find-package "SWANK")
	   (not (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) :spawn)))
      (error "When running clg in Slime, the communication style :spawn must be used in combination with multi threaded event handling. See the README file and <http://common-lisp.net/project/slime/doc/html/slime_45.html> for more information."))
    (let ((main-running (sb-thread:make-waitqueue)))
      (gdk:with-global-lock
       (setf *main-thread*
        (sb-thread:make-thread 
	 #'(lambda () 
	     (gdk:threads-init)	 
	     (gdk:with-global-lock 
	       (gdk:display-open display)
	       #+win32(gdk:timeout-add-with-lock (/ *event-poll-interval* 1000)
		       #'%funcall-in-main-poll)
	       (sb-thread:condition-notify main-running)
	       (main)))
	 :name "gtk event loop"))
	(sb-thread:condition-wait main-running gdk:*global-lock*)))
  
    ;; We need to hook into the Swank server to protect calls to GDK properly.
    ;; This will *only* protect code entered directly in the REPL.
    (when (find-package "SWANK")
      (push #'(lambda (form) 
		(within-main-loop (eval form)))
       swank::*slime-repl-eval-hooks*))))

#-sb-thread
(defmacro within-main-loop (&body body)
  `(progn ,@body))



;;; Generic functions 

(defgeneric add-to-radio-group (item1 item2))
(defgeneric activate-radio-widget (item))
(defgeneric (setf tool-item-tip-text) (tip-text tool-item))
(defgeneric (setf tool-item-tip-private) (tip-private tool-item))



;;; Misc

(defbinding grab-add () nil
  (widget widget))

(defbinding grab-get-current () widget)

(defbinding grab-remove () nil
  (widget widget))

(defbinding get-default-language () (copy-of pango:language))


;;; About dialog

#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
(progn
  (define-callback-marshal %about-dialog-activate-link-callback nil
    (about-dialog (link string)))

  (defbinding about-dialog-set-email-hook (function) nil
    (%about-dialog-activate-link-callback callback)
    ((register-callback-function function) unsigned-int)
    (user-data-destroy-callback callback))
  
  (defbinding about-dialog-set-url-hook (function) nil
    (%about-dialog-activate-link-callback callback)
    ((register-callback-function function) unsigned-int)
    (user-data-destroy-callback callback)))


;;; Acccel group

(defbinding %accel-group-connect () nil
  (accel-group accel-group)
  (key unsigned-int)
  (modifiers gdk:modifier-type)
  (flags accel-flags)
  (gclosure gclosure))

(defun accel-group-connect (group accelerator function &optional flags)
  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
    (let ((gclosure (make-callback-closure function)))
      (%accel-group-connect group key modifiers flags gclosure)
      gclosure)))

(defbinding accel-group-connect-by-path (group path function) nil
  (group accel-group)
  (path string)
  ((make-callback-closure function) gclosure :in/return))

(defbinding %accel-group-disconnect (group gclosure) boolean
  (group accel-group)
  (gclosure gclosure))

(defbinding %accel-group-disconnect-key () boolean
  (group accel-group)
  (key unsigned-int)
  (modifiers gdk:modifier-type))

(defun accel-group-disconnect (group accelerator)
  (etypecase accelerator
    (gclosure (%accel-group-disconnect group accelerator))
    (string 
     (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
       (%accel-group-disconnect-key group key modifiers)))))

(defbinding %accel-group-query () (copy-of (vector (inlined accel-group-entry) n))
  (accel-group accel-group)
  (key unsigned-int)
  (modifiers gdk:modifier-type)
  (n int :out))

(defun accel-group-query (accel-group accelerator)
  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
    (%accel-group-query accel-group key modifiers)))

(defbinding %accel-group-activate () boolean
  (accel-group accel-group)
  (acceleratable gobject)
  (key unsigned-int)
  (modifiers gdk:modifier-type))

(defun accel-group-activate (accel-group acceleratable accelerator)
  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
    (%accel-group-activate accel-group acceleratable key modifiers)))

(defbinding accel-group-lock () nil
  (accel-group accel-group))

(defbinding accel-group-unlock () nil
  (accel-group accel-group))

(defbinding accel-group-from-accel-closure () accel-group
  (closure gclosure))

(defbinding %accel-groups-activate () boolean
  (object gobject)
  (key unsigned-int)
  (modifiers gdk:modifier-type))

(defun accel-groups-activate (object accelerator)
  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
    (%accel-groups-activate object key modifiers)))

(defbinding accel-groups-from-object () (gslist accel-group)
  (object gobject))

(defbinding accelerator-valid-p (key &optional modifiers) boolean
  (key unsigned-int)
  (modifiers gdk:modifier-type))

(defbinding %accelerator-parse () nil
  (accelerator string)
  (key unsigned-int :out)
  (modifiers gdk:modifier-type :out))

(defgeneric parse-accelerator (accelerator))

(defmethod parse-accelerator ((accelerator string))
  (multiple-value-bind (key modifiers) (%accelerator-parse accelerator)
    (if (zerop key)
	(error "Invalid accelerator: ~A" accelerator)
      (values key modifiers))))

(defmethod parse-accelerator ((accelerator cons))
  (destructuring-bind (key modifiers) accelerator
    (values
     (etypecase key
       (integer key)
       (string
	(or 
	 (gdk:keyval-from-name key)
	 (error "Invalid key name: ~A" key)))
       (character (parse-accelerator key)))
     modifiers)))

(defmethod parse-accelerator ((key integer))
  key)

(defmethod parse-accelerator ((key character))
  (or
   (gdk:keyval-from-name (string key))
   (error "Invalid key name: ~A" key)))


(defbinding accelerator-name () string
  (key unsigned-int)
  (modifiers gdk:modifier-type))

#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
(defbinding accelerator-get-label () string
  (key unsigned-int)
  (modifiers gdk:modifier-type))

(defbinding %accelerator-set-default-mod-mask () nil
  (default-modifiers gdk:modifier-type))

(defun (setf accelerator-default-modifier-mask) (default-modifiers)
  (%accelerator-set-default-mod-mask default-modifiers))

(defbinding (accelerator-default-modifier-mask "gtk_accelerator_get_default_mod_mask") () gdk:modifier-type)


;;; Acccel label

(defbinding accel-label-get-accel-width () unsigned-int
  (accel-label accel-label))

(defbinding accel-label-refetch () boolean
  (accel-label accel-label))



;;; Accel map

(defbinding %accel-map-add-entry () nil
  (path string)
  (key unsigned-int)
  (modifiers gdk:modifier-type))

(defun accel-map-add-entry (path accelerator)
  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
    (%accel-map-add-entry path key modifiers)))

(defbinding %accel-map-lookup-entry () boolean
  (path string)
  ((make-instance 'accel-key) accel-key :in/return))

(defun accel-map-lookup-entry (path)
  (multiple-value-bind (found-p accel-key) (%accel-map-lookup-entry path)
    (when found-p
      (values 
       (slot-value accel-key 'key)
       (slot-value accel-key 'modifiers)
       (slot-value accel-key 'flags)))))

(defbinding %accel-map-change-entry () boolean
  (path string)
  (key unsigned-int)
  (modifiers gdk:modifier-type)
  (replace boolean))

(defun accel-map-change-entry (path accelerator &optional replace)
  (multiple-value-bind (key modifiers) (parse-accelerator accelerator)
    (%accel-map-change-entry path key modifiers replace)))

(defbinding accel-map-load () nil
  (filename pathname))

(defbinding accel-map-save () nil
  (filename pathname))

(define-callback-marshal %accel-map-foreach-callback nil
  ((accel-path string) (key unsigned-int) 
   (modifiers gdk:modifier-type) (changed boolean)) :callback-id :first)

(defbinding %accel-map-foreach (callback-id) nil
  (callback-id unsigned-int)
  (%accel-map-foreach-callback callback))

(defbinding %accel-map-foreach-unfiltered (callback-id) nil
  (callback-id unsigned-int)
  (%accel-map-foreach-callback callback))

(defun accel-map-foreach (function &optional (filter-p t))
  (with-callback-function (id function)
    (if filter-p			  
	(%accel-map-foreach id)
      (%accel-map-foreach-unfiltered id))))

(defbinding accel-map-add-filter () nil
  (filter string))

(defbinding accel-map-get () accel-map)

(defbinding accel-map-lock-path () nil
  (path string))

(defbinding accel-map-unlock-path () nil
  (path string))



;;; Accessibility

(defbinding accessible-connect-widget-destroyed () nil
  (accessible accessible))


;;; Adjustment

(defmethod initialize-instance ((adjustment adjustment) &key value)
  (prog1
      (call-next-method)
    ;; we need to make sure that the value is set last, otherwise it
    ;; may be outside current limits and ignored
    (when value
      (setf (slot-value adjustment 'value) value))))


(defbinding adjustment-changed () nil
  (adjustment adjustment))

(defbinding adjustment-value-changed () nil
  (adjustment adjustment))

(defbinding adjustment-clamp-page () nil
  (adjustment adjustment)
  (lower single-float)
  (upper single-float))


;;; Alignment

(defbinding alignment-set () nil
  (alognment alignment)
  (x-align single-float)
  (y-align single-float)
  (x-scale single-float)
  (y-scale single-float))

(defbinding alignment-get-padding () nil
  (alognment alignment)
  (top unsigned-int :out)
  (bottom unsigned-int :out)
  (left unsigned-int :out)
  (right unsigned-int :out))

(defbinding alignment-set-padding () nil
  (alognment alignment)
  (top unsigned-int)
  (bottom unsigned-int)
  (left unsigned-int)
  (right unsigned-int))


;;; Assistant

#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
(progn
  (defbinding assistant-get-nth-page () widget
    (assistant assistant)
    (page-num int))
  
  (defbinding %assistant-insert-page () int
    (assistant assistant)
    (page widget)
    (pos int))

  (defun assistant-insert-page (assistant page position &rest child-args)    
    (let ((pos (case position
		 (:first 0)
		 (:last -1)
		 (t position))))
      (prog1
	  (%assistant-insert-page assistant page pos)
	(init-child-slots assistant page child-args))))
  
  (defun assistant-append-page (assistant page &rest child-args)
    (apply #'assistant-insert-page assistant page :last child-args))
  
  (defun assistant-prepend-page (assistant page &rest child-args)
    (apply #'assistant-insert-page assistant page :first child-args))

  (define-callback-marshal %assistant-page-func-callback int
    ((current-page int)))

  (defbinding assistant-set-forward-page-func (assistant function) nil
    (assistant assistant)
    (%assistant-page-func-callback callback)
    ((register-callback-function function) pointer-data)
{'fraction_non_alphanumeric': 0.13895988283605662, 'fraction_numerical': 0.005800763862964133, 'mean_word_length': 3.873215785054576, 'pattern_counts': {'":': 0, '<': 23, '<?xml version=': 0, '>': 15, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1397652', 'n_tokens_mistral': 12073, 'n_tokens_neox': 11349, 'n_words': 3119}