Minor changes for win32

[clg] / gtk / gtk.lisp

diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp
index abae2e3a006e65b3600e1f47cae8981a5102aded..38c61bbf9cc5814d432e99dd005b23e0384622d7 100644 (file)
--- a/gtk/gtk.lisp
+++ b/gtk/gtk.lisp
@@ -20,7 +20,7 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
 ;; 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.65 2006/09/13 10:54:49 espen Exp $
+;; $Id: gtk.lisp,v 1.71 2007/06/01 09:17:17 espen Exp $

 
 
 (in-package "GTK")
 
 
 (in-package "GTK")


@@ -48,7 +48,7 @@ (defun clg-version ()
   "clg 0.93")
 
 
   "clg 0.93")
 
 

-;;;; Initalization
+;;;; Initalization and display handling

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


@@ -58,7 +58,7 @@ (defbinding (gtk-init "gtk_parse_args") () boolean
 (defparameter *event-poll-interval* 10000)
 
 (defun clg-init (&optional display)
 (defparameter *event-poll-interval* 10000)
 
 (defun clg-init (&optional display)

-  "Initializes the system and starts the event handling"
+  "Initializes the system and starts event handling"

   #+sbcl(when (and 
               (find-package "SWANK")
               (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) :spawn))
   #+sbcl(when (and 
               (find-package "SWANK")
               (eq (symbol-value (find-symbol "*COMMUNICATION-STYLE*" "SWANK")) :spawn))


@@ -73,35 +73,46 @@ (defun clg-init (&optional display)
     (gdk:gdk-init)
     (unless (gtk-init)
       (error "Initialization of GTK+ failed."))
     (gdk:gdk-init)
     (unless (gtk-init)
       (error "Initialization of GTK+ failed."))

-    (prog1
-       (gdk:display-open display)
-      #+(or cmu sbcl)
-      (progn
-       (add-fd-handler (gdk:display-connection-number) :input #'main-iterate-all)
-       (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)
-      #+clisp      
-      ;; When running in Slime we need to hook into the Swank server
-      ;; to handle events asynchronously
-      (if (find-package "SWANK")
-         (let ((read-from-emacs (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:socket-status (cons stream :input) 0 *event-poll-interval*)
-                   (:input (return (funcall read-from-emacs)))
-                   (:eof (read-char stream))
-                   (otherwise (main-iterate-all)))))))
-       #-readline(warn "Not running in Slime and Readline support is missing, so the Gtk main loop has to be invoked explicit.")))))
+    #+(or cmu sbcl)
+    (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)
+    #+clisp      
+    ;; 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:socket-status (cons stream :input) 0 *event-poll-interval*)
+                 (:input (return (funcall read-from-emacs)))
+                 (:eof (read-char stream))
+                 (otherwise (main-iterate-all)))))))
+      #-readline(warn "Not running in Slime and Readline support is missing, so the Gtk main loop has to be invoked explicit."))
+
+    (gdk:display-open display)))
+

 
 #+sbcl   
 (defun clg-init-with-threading (&optional display)
 
 #+sbcl   
 (defun clg-init-with-threading (&optional display)

-  "Initializes the system and starts the event handling"
+  "Initializes the system and starts event handling"

   (unless (gdk:display-get-default)
     #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
     (progn
   (unless (gdk:display-get-default)
     #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
     (progn


@@ -436,11 +447,11 @@ (defun (setf bin-child) (child bin)
   (container-add bin child)
   child)
 
   (container-add bin child)
   child)
 

-(defmethod compute-signal-function ((bin bin) signal function object)
+(defmethod compute-signal-function ((bin bin) signal function object args)

   (declare (ignore signal))
   (if (eq object :child)
   (declare (ignore signal))
   (if (eq object :child)

-      #'(lambda (&rest args) 
-         (apply function (bin-child bin) (rest args)))
+      #'(lambda (&rest emission-args) 
+         (apply function (bin-child bin) (nconc (rest emission-args) args)))

     (call-next-method)))
 
 
     (call-next-method)))
 
 


@@ -670,8 +681,8 @@ (defmethod compute-signal-id ((dialog dialog) signal)
       (ensure-signal-id 'response dialog)
     (call-next-method)))
 
       (ensure-signal-id 'response dialog)
     (call-next-method)))
 

-(defmethod compute-signal-function ((dialog dialog) signal function object)
-  (declare (ignore function object))
+(defmethod compute-signal-function ((dialog dialog) signal function object args)
+  (declare (ignore function object args))

   (let ((callback (call-next-method))
        (id (dialog-response-id dialog signal)))
     (if id
   (let ((callback (call-next-method))
        (id (dialog-response-id dialog signal)))
     (if id


@@ -781,6 +792,12 @@ (defmethod (setf container-children) (children (dialog dialog))
   (setf (container-children (dialog-vbox dialog)) children))
 
 
   (setf (container-children (dialog-vbox dialog)) children))
 
 

+;;; Drawing Area
+
+(defun drawing-area-scroll (drawing-area dx dy)
+  (gdk:window-scroll (widget-window drawing-area) dx dy))
+
+

 ;;; Entry
 
 (defbinding entry-get-layout-offsets () nil
 ;;; Entry
 
 (defbinding entry-get-layout-offsets () nil


@@ -1068,6 +1085,8 @@ (defun %add-activate-callback (widget signal function object after)
 (defmethod activate-radio-widget ((button radio-button))
   (signal-emit button 'clicked))
 
 (defmethod activate-radio-widget ((button radio-button))
   (signal-emit button 'clicked))
 

+(defgeneric add-activate-callback (action function &key object after))
+

 (defmethod add-activate-callback ((button radio-button) function &key object after)
   (%add-activate-callback button 'clicked function object after))
 
 (defmethod add-activate-callback ((button radio-button) function &key object after)
   (%add-activate-callback button 'clicked function object after))
 


@@ -1482,10 +1501,14 @@ (defun (setf window-default-icon-list) (icons)
 (defbinding %window-set-default-icon () nil
   (icons (glist gdk:pixbuf)))
 
 (defbinding %window-set-default-icon () nil
   (icons (glist gdk:pixbuf)))
 

+(defgeneric (setf window-default-icon) (icon))
+

 (defmethod (setf window-default-icon) ((icon gdk:pixbuf))
   (%window-set-default-icon icon)
   icon)
 
 (defmethod (setf window-default-icon) ((icon gdk:pixbuf))
   (%window-set-default-icon icon)
   icon)
 

+(defgeneric (setf window-group) (group window))
+

 (defmethod (setf window-group) ((group window-group) (window window))
   (window-group-add-window group window)
   group)
 (defmethod (setf window-group) ((group window-group) (window window))
   (window-group-add-window group window)
   group)


@@ -1971,12 +1994,16 @@ (defbinding %table-set-col-spacings () nil
   (table table)
   (spacing unsigned-int))
 
   (table table)
   (spacing unsigned-int))
 

-(defun (setf table-col-spacing) (spacing table &optional col)
-  (if col
-      (%table-set-col-spacing table col spacing)
+(defun (setf table-column-spacing) (spacing table &optional column)
+  (if column
+      (%table-set-col-spacing table column spacing)

     (%table-set-col-spacings table spacing))
   spacing)
 
     (%table-set-col-spacings table spacing))
   spacing)
 

+(defun (setf table-col-spacing) (spacing table &optional col)
+  (warn "TABLE-COL-SPACING is deprecatet, use TABLE-COLUMN-SPACING instead")
+  (setf (table-column-spacing table col) spacing))
+

 (defbinding %table-get-col-spacing () unsigned-int
   (table table)
   (col unsigned-int))
 (defbinding %table-get-col-spacing () unsigned-int
   (table table)
   (col unsigned-int))


@@ -1984,11 +2011,15 @@ (defbinding %table-get-col-spacing () unsigned-int
 (defbinding %table-get-default-col-spacing () unsigned-int
   (table table))
 
 (defbinding %table-get-default-col-spacing () unsigned-int
   (table table))
 

-(defun table-col-spacing (table &optional col)
-  (if col
-      (%table-get-col-spacing table col)
+(defun table-column-spacing (table &optional column)
+  (if column
+      (%table-get-col-spacing table column)

     (%table-get-default-col-spacing table)))
   
     (%table-get-default-col-spacing table)))
   

+(defun table-col-spacing (table &optional col)
+  (warn "TABLE-COL-SPACING is deprecatet, use TABLE-COLUMN-SPACING instead")
+  (table-column-spacing table col))
+

 
 
 ;;; Toolbar
 
 
 ;;; Toolbar


@@ -2406,3 +2437,17 @@ (defbinding %plug-new () pointer
 
 (defmethod allocate-foreign ((plug plug) &key id)
   (%plug-new (or id 0)))
 
 (defmethod allocate-foreign ((plug plug) &key id)
   (%plug-new (or id 0)))

+
+
+;;;; New stuff in Gtk+ 2.10
+
+;;; Link button
+
+#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
+(progn
+  (define-callback-marshal %link-button-uri-callback nil (link-button (link string)))
+
+  (defbinding link-button-set-uri-hook (function) pointer
+    (%link-button-uri-callback callback)
+    ((register-callback-function function) unsigned-int)
+    (user-data-destroy-callback callback)))