mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Drei/cl-automaton
by thenriksen 08 Nov '06

08 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton In directory clnet:/tmp/cvs-serv24849/cl-automaton Log Message: Directory /project/mcclim/cvsroot/mcclim/Drei/cl-automaton added to the repository

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 08 Nov '06

08 Nov '06

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv24784/ESA Added Files: utils.lisp packages.lisp esa.lisp esa.asd esa-io.lisp esa-command-parser.lisp esa-buffer.lisp colors.lisp Log Message: Committed ESA. --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2006/11/08 01:10:16 1.1 ;;; -*- Mode: Lisp; Package: ESA-UTILS -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Miscellaneous utilities used in Climacs. (in-package :esa-utils) ;;; Cribbed from Paul Graham (defmacro with-gensyms (syms &body body) `(let ,(mapcar #'(lambda (s) `(,s (gensym))) syms) ,@body)) ;;; Cribbed from PCL by Seibel (defmacro once-only ((&rest names) &body body) (let ((gensyms (loop for n in names collect (gensym)))) `(let (,@(loop for g in gensyms collect `(,g (gensym)))) `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) ,@body))))) (defun unlisted (obj &optional (fn #'first)) (if (listp obj) (funcall fn obj) obj)) (defun fully-unlisted (obj &optional (fn #'first)) (if (listp obj) (fully-unlisted (funcall fn obj)) obj)) (defun listed (obj) (if (listp obj) obj (list obj))) (defun list-aref (list &rest subscripts) (if subscripts (apply #'list-aref (nth (first subscripts) list) (rest subscripts)) list)) ;;; Cribbed from McCLIM. (defun check-letf-form (form) (assert (and (listp form) (= 2 (length form))))) (defun valueify (list) (if (and (consp list) (endp (rest list))) (first list) `(values ,@list))) (defmacro letf ((&rest forms) &body body &environment env) "LETF ({(Place Value)}*) Declaration* Form* During evaluation of the Forms, SETF the Places to the result of evaluating the Value forms. The places are SETF-ed in parallel after all of the Values are evaluated." (mapc #'check-letf-form forms) (let* (init-let-form save-old-values-setf-form new-values-set-form old-values-set-form update-form) (loop for (place new-value) in forms for (vars vals store-vars writer-form reader-form) = (multiple-value-list (get-setf-expansion place env)) for old-value-names = (mapcar (lambda (var) (declare (ignore var)) (gensym)) store-vars) nconc (mapcar #'list vars vals) into temp-init-let-form nconc (copy-list store-vars) into temp-init-let-form nconc (copy-list old-value-names) into temp-init-let-form nconc `(,(valueify old-value-names) ,reader-form) into temp-save-old-values-setf-form nconc `(,(valueify store-vars) ,new-value) into temp-new-values-set-form nconc `(,(valueify store-vars) ,(valueify old-value-names)) into temp-old-values-set-form collect writer-form into temp-update-form finally (setq init-let-form temp-init-let-form save-old-values-setf-form temp-save-old-values-setf-form new-values-set-form temp-new-values-set-form old-values-set-form temp-old-values-set-form update-form (cons 'progn temp-update-form))) `(let* ,init-let-form (setf ,@save-old-values-setf-form) (unwind-protect (progn (setf ,@new-values-set-form) ,update-form (progn ,@body)) (setf ,@old-values-set-form) ,update-form)))) (defun invoke-with-dynamic-bindings-1 (bindings continuation) (let ((old-values (mapcar #'(lambda (elt) (symbol-value (first elt))) bindings))) (unwind-protect (progn (mapcar #'(lambda (elt) (setf (symbol-value (first elt)) (funcall (second elt)))) bindings) (funcall continuation)) (mapcar #'(lambda (elt value) (setf (symbol-value (first elt)) value)) bindings old-values)))) (defmacro invoke-with-dynamic-bindings ((&rest bindings) &body body) `(invoke-with-dynamic-bindings-1 ,(loop for (symbol expression) in bindings collect (list `',symbol `#'(lambda () ,expression))) #'(lambda () ,@body))) ;;; XXX This is currently broken with respect to declarations (defmacro letf* ((&rest forms) &body body) (if (null forms) `(locally ,@body) `(letf (,(car forms)) (letf* (,(cdr forms)) ,@body)))) (defun display-string (string) (with-output-to-string (result) (loop for char across string do (cond ((graphic-char-p char) (princ char result)) ((char= char #\Space) (princ char result)) (t (prin1 char result)))))) (defun object-equal (x y) "Case insensitive equality that doesn't require characters" (if (characterp x) (and (characterp y) (char-equal x y)) (eql x y))) (defun object= (x y) "Case sensitive equality that doesn't require characters" (if (characterp x) (and (characterp y) (char= x y)) (eql x y))) (defun no-upper-p (string) "Does STRING contain no uppercase characters" (notany #'upper-case-p string)) (defun case-relevant-test (string) "Returns a test function based on the search-string STRING. If STRING contains no uppercase characters the test is case-insensitive, otherwise it is case-sensitive." (if (no-upper-p string) #'object-equal #'object=)) (defun remove-keywords (arg-list keywords) (let ((clean-tail arg-list)) ;; First, determine a tail in which there are no keywords to be removed. (loop for arg-tail on arg-list by #'cddr for (key) = arg-tail do (when (member key keywords :test #'eq) (setq clean-tail (cddr arg-tail)))) ;; Cons up the new arg list until we hit the clean-tail, then nconc that on ;; the end. (loop for arg-tail on arg-list by #'cddr for (key value) = arg-tail if (eq arg-tail clean-tail) nconc clean-tail and do (loop-finish) else if (not (member key keywords :test #'eq)) nconc (list key value) end))) (defmacro with-keywords-removed ((var keywords &optional (new-var var)) &body body) "binds NEW-VAR (defaults to VAR) to VAR with the keyword arguments specified in KEYWORDS removed." `(let ((,new-var (remove-keywords ,var ',keywords))) ,@body))--- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2006/11/08 01:10:16 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2004-2006 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Package definitions for ESA. (defpackage :esa-utils (:use :clim-lisp) (:export #:with-gensyms #:once-only #:unlisted #:fully-unlisted #:listed #:list-aref #:letf #:letf* #:display-string #:object-equal #:object= #:no-upper-p #:case-relevant-test #:with-keywords-removed #:invoke-with-dynamic-bindings-1 #:invoke-with-dynamic-bindings)) (defpackage :esa (:use :clim-lisp :clim :esa-utils) (:export #:buffers #:frame-current-buffer #:current-buffer #:*current-buffer* #:windows #:frame-current-window #:current-window #:*current-window* #:*previous-command* #:*minibuffer* #:minibuffer #:minibuffer-pane #:display-message #:with-minibuffer-stream #:esa-pane-mixin #:previous-command #:info-pane #:master-pane #:esa-frame-mixin #:recordingp #:executingp #:*esa-abort-gestures* #:*numeric-argument-p* #:*current-gesture* #:*command-processor* #:unbound-gesture-sequence #:gestures #:command-processor #:instant-macro-execution-mixin #:macrorecord-processed-gestures-mixin #:asynchronous-command-processor #:command-loop-command-processor #:overriding-handler #:directly-processing-p #:process-gesture #:process-gestures-or-command #:*extended-command-prompt* #:define-esa-top-level #:esa-top-level #:simple-command-loop #:convert-to-gesture #:gesture-name #:global-esa-table #:keyboard-macro-table #:help-table #:help-stream #:set-key #:find-applicable-command-table #:esa-command-parser #:esa-partial-command-parser #:gesture-matches-gesture-name-p #:meta-digit #:proper-gesture-p #:universal-argument #:meta-minus)) (defpackage :esa-buffer (:use :clim-lisp :clim :esa :esa-utils) (:export #:frame-make-buffer-from-stream #:make-buffer-from-stream #:frame-save-buffer-to-stream #:save-buffer-to-stream #:filepath #:name #:needs-saving #:file-write-time #:file-saved-p #:esa-buffer-mixin #:frame-make-new-buffer #:make-new-buffer #:read-only-p)) (defpackage :esa-io (:use :clim-lisp :clim :esa :esa-buffer :esa-utils) (:export #:frame-find-file #:find-file #:frame-find-file-read-only #:find-file-read-only #:frame-set-visited-file-name #:set-visited-filename #:frame-save-buffer #:save-buffer #:frame-write-buffer #:write-buffer #:esa-io-table)) #-(or mcclim building-mcclim) (defpackage :clim-extensions (:use :clim-lisp :clim) (:export #:+blue-violet+ #:+dark-blue+ #:+dark-green+ #:+dark-violet+ #:+gray50+ #:+gray85+ #:+maroon+ #:+purple+))--- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2006/11/08 01:10:16 1.1 ;;; -*- Mode: Lisp; Package: ESA -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Emacs-Style Appication (in-package :esa) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Querying ESAs. (defgeneric buffers (application-frame) (:documentation "Return a list of all the buffers of the application.")) (defgeneric frame-current-buffer (application-frame) (:documentation "Return the current buffer of APPLICATION-FRAME.") (:method ((frame application-frame)) nil)) (defvar *current-buffer* nil "When a command is being executed, the current buffer.") (defun current-buffer () "Return the current buffer of `*application-frame*'." (frame-current-buffer *application-frame*)) (defgeneric windows (application-frame) (:documentation "Return a list of all the windows of the application.") (:method ((application-frame application-frame)) '())) (defgeneric frame-current-window (application-frame) (:documentation "Return the current window of APPLICATION-FRAME.") (:method ((frame application-frame)) (first (windows frame)))) (defvar *current-window* nil "When a command is being executed, the current window.") (defun current-window () "Return the current window of `*application-frame*'." (frame-current-window *application-frame*)) (defvar *previous-command* nil "When a command is being executed, the command previously executed by the current frame.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Info pane, a pane that displays some information about another pane (defclass info-pane (application-pane) ((master-pane :initarg :master-pane :reader master-pane)) (:default-initargs :background +gray85+ :scroll-bars nil :borders nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Minibuffer pane (defgeneric minibuffer (application-frame) (:documentation "Return the minibuffer of `application-frame'.")) (defvar *minibuffer* nil "The minibuffer pane of the running application.") (defvar *minimum-message-time* 1 "The minimum number of seconds a minibuffer message will be displayed." ) (defclass minibuffer-pane (application-pane) ((message :initform nil :accessor message :documentation "An output record containing whatever message is supposed to be displayed in the minibuffer.") (message-time :initform 0 :accessor message-time :documentation "The universal time at which the current message was set.")) (:default-initargs :scroll-bars nil :display-function 'display-minibuffer [1505 lines skipped] --- /project/mcclim/cvsroot/mcclim/ESA/esa.asd 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/esa.asd 2006/11/08 01:10:16 1.1 [1543 lines skipped] --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2006/11/08 01:10:16 1.1 [1899 lines skipped] --- /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2006/11/08 01:10:16 1.1 [2020 lines skipped] --- /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp 2006/11/08 01:10:16 1.1 [2074 lines skipped] --- /project/mcclim/cvsroot/mcclim/ESA/colors.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/colors.lisp 2006/11/08 01:10:16 1.1 [2108 lines skipped]

1 0

[mcclim-cvs] CVS mcclim/ESA
by thenriksen 08 Nov '06

08 Nov '06

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv24623/ESA Log Message: Directory /project/mcclim/cvsroot/mcclim/ESA added to the repository

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 05 Nov '06

05 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv32229 Modified Files: gtk-ffi.lisp medium.lisp port.lisp Log Message: Make gsharp pretty. * gtk-ffi.lisp (gdk_draw_rectangle, gdk_gc_set_rgb_fg_color): New declarations. * medium.lisp (medium-draw-point*, medium-draw-points*): Draw the line in a 45 deg angle, resulting in a fully saturated color. * port.lisp ((realize-mirror pixmap)): Clear the pixmap using white color. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 18:43:19 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 21:23:11 1.11 @@ -602,6 +602,21 @@ (width :int) (height :int)) +(defcfun "gdk_draw_rectangle" + :void + (drawable :pointer) + (gc :pointer) + (filled :int) + (x :int) + (y :int) + (width :int) + (height :int)) + +(defcfun "gdk_gc_set_rgb_fg_color" + :void + (gc :pointer) + (color :pointer)) + (defcfun "gtk_button_new" :pointer ) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/05 18:49:13 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/05 21:23:12 1.11 @@ -446,7 +446,7 @@ (setf x (df x)) (setf y (df y)) (cairo_move_to cr x y) - (cairo_line_to cr (+ x (/ x (expt 2 16))) y) + (cairo_line_to cr (+ x 0.5) (+ y 0.5)) (cairo_stroke cr)))) (defmethod medium-draw-points* ((medium gtkairo-medium) coord-seq) @@ -462,7 +462,7 @@ (let ((x (df (elt coord-seq (+ i 0)))) (y (df (elt coord-seq (+ i 1))))) (cairo_move_to cr x y) - (cairo_line_to cr (+ x (/ x (expt 2 16))) y) + (cairo_line_to cr (+ x 0.5) (+ y 0.5)) (cairo_stroke cr)))))) (defmethod medium-draw-line* ((medium gtkairo-medium) x1 y1 x2 y2) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/05 18:43:19 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/05 21:23:12 1.7 @@ -379,12 +379,20 @@ (let* ((drawable (mirror-drawable (sheet-direct-mirror (climi::pixmap-sheet pixmap-sheet)))) - (pixmap - (gdk_pixmap_new drawable - (round (pixmap-width pixmap-sheet)) - (round (pixmap-height pixmap-sheet)) - -1)) - (mirror (make-instance 'drawable-mirror :drawable pixmap))) + (w (round (pixmap-width pixmap-sheet))) + (h (round (pixmap-height pixmap-sheet))) + (pixmap (gdk_pixmap_new drawable w h -1)) + (mirror (make-instance 'drawable-mirror :drawable pixmap)) + (gc (gdk_gc_new pixmap))) + (cffi:with-foreign-object (c 'gdkcolor) + (setf (cffi:foreign-slot-value c 'gdkcolor 'pixel) 0) + (setf (values (cffi:foreign-slot-value c 'gdkcolor 'r) + (cffi:foreign-slot-value c 'gdkcolor 'g) + (cffi:foreign-slot-value c 'gdkcolor 'b)) + (values 65535 65535 65535)) + (gdk_gc_set_rgb_fg_color gc c)) + (gdk_draw_rectangle pixmap gc 1 0 0 w h) + (gdk_gc_unref gc) (climi::port-register-mirror port pixmap-sheet mirror) mirror)))

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 05 Nov '06

05 Nov '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5752 Modified Files: mcclim.asd Log Message: Easier Gtkairo building on Windows: If the :GTKAIRO feature is set, disable the dependency from CLIM-LOOKS to CLIM-CLX. This way, the default is to load CLIM-CLX as usual, but users who explicitly request Gtkairo can build without CLX and sb-bsd-sockets. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/05 18:22:07 1.31 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/05 19:00:54 1.32 @@ -295,7 +295,8 @@ :depends-on (:clim :clim-postscript ;; If we're on an implementation that ships CLX, use ;; it. Same if the user has loaded CLX already. - #+(or sbcl scl openmcl ecl clx allegro) :clim-clx + #+(and (or sbcl scl openmcl ecl clx allegro) (not gtkairo)) + :clim-clx #+gl :clim-opengl ;; OpenMCL and MCL support the beagle backend (native ;; OS X look&feel on OS X). @@ -309,7 +310,8 @@ ;; null backend :clim-null ) - :components ((:file "Looks/pixie" + :components (#-gtkairo + (:file "Looks/pixie" :pathname #.(make-pathname :directory '(:relative "Looks") :name "pixie" :type "lisp")))) ;;; name of :clim-clx-user chosen by mikemac for no good reason

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 05 Nov '06

05 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv3334 Modified Files: BUGS medium.lisp Log Message: Fixed bugs 6b and 7b. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/06/10 10:08:49 1.11 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/11/05 18:49:13 1.12 @@ -30,7 +30,7 @@ (FIXED) 6. [Address book didn't work on windows.] -6b. +(FIXED) 6b. On windows, something draws gray ink over the buttons in demodemo after expose events. This should not happen, since the gtkbuttons are in a gtkfixed with its own window. Thorough double buffering @@ -44,7 +44,7 @@ flipping ink takes time proportional to the with the size of the window, not with the size of the shape being drawn -7b. +(FIXED) 7b. (problem appears to be gone with double buffering) flipping ink pixmap caching is broken on windows 7c. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/05 17:22:23 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/05 18:49:13 1.10 @@ -236,9 +236,7 @@ (cairo_surface_mark_dirty to-surface)) (cairo_destroy (cr medium)) (setf (cr medium) (flipping-original-cr medium)) - (setf (flipping-original-cr medium) nil) - #+(or win32 mswindows windows) ;fixme - (dispose-flipping-pixmap medium)) + (setf (flipping-original-cr medium) nil)) (defmethod sync-ink (medium (design climi::standard-flipping-ink)) (setf (flipping-original-cr medium) (cr medium))

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 05 Nov '06

05 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv2828 Modified Files: event.lisp gtk-ffi.lisp port.lisp Log Message: restore build on windows --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/05 17:22:23 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/05 18:43:19 1.10 @@ -86,11 +86,11 @@ (car c))))) (defun dribble-x-errors () + #-(or win32 windows mswindows) (unless (zerop *-gdk-error-code*) (warn "Ignoring X error ~D: ~A" *-gdk-error-code* (cffi:with-foreign-pointer-as-string (buf 64) - #-(or win32 windows mswindows) (XGetErrorText *gdk-display* *-gdk-error-code* buf 63))) (setf *-gdk-error-code* 0))) @@ -107,6 +107,7 @@ (defmethod get-next-event ((port gtkairo-port) &key wait-function (timeout nil)) (declare (ignore wait-function)) + #-clim-mp (port-force-output port) (gtk-main-iteration port) (cond ((dequeue port)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 17:29:11 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 18:43:19 1.10 @@ -136,6 +136,7 @@ (cffi:defcvar "_gdk_error_warnings" :int) (cffi:defcvar "_gdk_error_code" :int) +#-(or win32 mswindows windows) (cffi:defcfun "XGetErrorText" :void (display :pointer) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/05 17:22:23 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/05 18:43:19 1.6 @@ -75,6 +75,7 @@ (when (zerop *g-threads-got-initialized*) (g_thread_init (cffi:null-pointer)) (gdk_threads_init) + #-(or win32 windows mswindows) (setf *-gdk-error-warnings* 0)) (with-gtk () ;; FIXME: hier koennten wir mindestens ein anderes --display uebergeben

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 05 Nov '06

05 Nov '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv32102 Modified Files: mcclim.asd Log Message: update gtkairo build order --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/02 19:41:41 1.30 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/05 18:22:07 1.31 @@ -270,12 +270,12 @@ (:file "package") (:file "gtk-ffi") (:file "cairo-ffi") + (:file "graft") (:file "port") (:file "event") (:file "keysymdef") (:file "medium") (:file "pixmap") - (:file "graft") (:file "frame-manager") (:file "gadgets")))))

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 05 Nov '06

05 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv23936 Modified Files: cairo-ffi.lisp gtk-ffi.lisp Log Message: Patch by Douglas Crosher, <4543F391.9000708(a)scieneer.com> --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/10/28 17:49:24 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/11/05 17:29:11 1.7 @@ -41,14 +41,8 @@ ,@args) (defun ,wrapper ,argnames (multiple-value-prog1 - ;; FIXME: This should probably go into with-cairo-floats. - ;; (see http://www.ircbrowse.com/channel/lisp/20061028?utime=3371045114#utime_reque…) - #-scl (,actual ,@argnames) - #+scl - (ext:with-float-traps-masked (:underflow :overflow :inexact - :divide-by-zero :invalid) - (,actual ,@argnames)) - (let ((status (cairo_status ,(car argnames)))) + (,actual ,@argnames) + (let ((status (cairo_status ,(car argnames)))) (unless (eq status :success) (error "~A returned with status ~A" ,name status)))))))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 17:22:23 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 17:29:11 1.9 @@ -85,12 +85,23 @@ ;; reset all options afterwards, I get lisp errors like f-p-i-o for, say, ;; (ATAN -13 13/2) in McCLIM. Isn't SBCL responsible for calling C code ;; with the with the modes C code expects? Or does cairo change them? +#+sbcl (defmacro with-cairo-floats ((&optional) &body body) `(unwind-protect (progn - #+sbcl (sb-int:set-floating-point-modes :traps nil) + (sb-int:set-floating-point-modes :traps nil) ,@body) - #+sbcl (apply #'sb-int:set-floating-point-modes *normal-modes*))) + (apply #'sb-int:set-floating-point-modes *normal-modes*))) + +#+(or scl cmu) +(defmacro with-cairo-floats ((&optional) &body body) + `(ext:with-float-traps-masked + (:underflow :overflow :inexact :divide-by-zero :invalid) + ,@body)) + +#-(or scl cmu sbcl) +(defmacro with-cairo-floats ((&optional) &body body) + `(progn ,@body)) ;; Note: There's no need for locking in single threaded mode for most ;; functions, except that the main loop functions try to release the

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 05 Nov '06

05 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv23372 Modified Files: clim-fix.lisp event.lisp gtk-ffi.lisp medium.lisp port.lisp Log Message: Low-flicker drawing: Double-buffer everything. * clim-fix.lisp (HANDLE-REPAINT, HIGHLIGHT-OUTPUT-RECORD-RECTANGLE): Use FORCE-OUTPUT on the SHEET instead of MEDIUM-FORCE-OUTPUT. * event.lisp (EXPOSE-HANDLER): If the mirror has a valid double buffering pixmap, has just blit the exposed rectangle to screen. Else, this must be the first redraw after initialization (A) or resize (B), so enqueue a window repaint event to get things going. For case A, clear the actual widget, since the frontend assumes mirrors to be filled with the background color if it never handles repaints on it. In case B, mark the pixmap as complete again. * gtk-ffi.lisp (gdk_window_invalidate_rect): New declaration. * medium.lisp (SYNC-SHEET): Mark the medium as dirty. (MEDIUM-FINISH-OUTPUT): Call medium-force-output after flushing the cairo surface. (MEDIUM-FORCE-OUTPUT): Remove the medium from the dirty table and invalidate the mirror. (INVALIDATE-MIRROR): For widget mirrors (with a double buffering pixmap), send an expose event. * port.lisp (*DOUBLE-BUFFERING-P*): New variable. (PORT): New slot DIRTY-MEDIUMS. (WIDGET-MIRROR): New slots PORT, BUFFERING-PIXMAP, BUFFERING-PIXMAP-P. (DRAWABLE-MIRROR): Additional accessor for the drawable slot, called MIRROR-REAL-DRAWABLE. ((MIRROR-REAL-DRAWABLE WIDGET-MIRROR)): Return the gdk window. (MIRROR-DRAWABLE): New method. Return or install the double buffering pixmap if *DOUBLE-BUFFERING-P* is enabled. Else return the real drawable. (REALIZE-WINDOW-MIRROR, REALIZE-MIRROR): Set the mirror's PORT slot. ((DESTROY-MIRROR MIRRORED-SHEET-MIXIN)): Free the double buffering pixmap. (RESET-MEDIUMS): Create a new double buffering pixmap for current size, copy over the old content, mark the pixmap as incomplete, and free the old one. (PORT-SET-MIRROR-REGION): Call RESET-MEDIUMS only after the resize has happened. (PORT-SET-MIRROR-TRANSFORMATION): No need to call RESET-MEDIUMS. (PORT-FORCE-OUTPUT): Call MEDIUM-FORCE-OUTPUT for all dirty mediums. Don't exit on X errors: * gtk-ffi.lisp (_gdk_error_warnings, _gdk_error_code, XGetErrorText): New declarations. * event.lisp (DRIBBLE-X-ERRORS): New function. (GTK-MAIN-ITERATION): Call DRIBBLE-X-ERRORS. * port.lisp (initialize-instance): Turn off `gdk-error-warnings', thereby disabling the GTk+'s "exit on error" behaviour. (PORT-FORCE-OUTPUT): Call DRIBBLE-X-ERRORS. Implement the weird pointer tracking code CLIM-CLX has: * port.lisp (PORT): New slot POINTER-GRAB-SHEET. (PORT-GRAB-POINTER): Set POINTER-GRAB-SHEET. (PORT-UNGRAB-POINTER): Clear POINTER-GRAB-SHEET if it is equal to the ungrabbing sheet. (DISTRIBUTE-EVENT :AROUND): Send events to the grabbing sheet no matter what. Misc: * event.lisp (ENTER-HANDLER): Set PORT-POINTER-SHEET manually, fixing a problem with the Drag and Drop demo. * medium.lisp (SYNC-TRANSFORMATION): Error out on invalid transformation -before- installing them into the cairo context. ((SYNC-INK FLIPPING-INK)): Removed unused binding of allocation size. * port.lisp (PORT-MIRROR-WIDTH, PORT-MIRROR-HEIGHT): Implemented. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/05/02 13:02:09 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/11/05 17:22:23 1.5 @@ -36,8 +36,7 @@ ;; multiple times and looks like crap. This fixes it: (clim:with-drawing-options (m :clipping-region r) (clim:draw-design m r :ink clim:+background-ink+) - (call-next-method s r))) - (medium-force-output m))) + (call-next-method s r))))) ;; cairo hack: adjust rectangle coordinates by half a pixel each to avoid ;; anti-aliasing (and follow-up output artifacts) @@ -58,4 +57,5 @@ ;; FIXME: repaint the hit detection rectangle. It could be ;; bigger than ;; the bounding rectangle. - (repaint-sheet stream record)))))) + (repaint-sheet stream record))) + (force-output stream)))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/05/13 19:37:29 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/05 17:22:23 1.9 @@ -85,6 +85,15 @@ (pop (events-head port)) (car c))))) +(defun dribble-x-errors () + (unless (zerop *-gdk-error-code*) + (warn "Ignoring X error ~D: ~A" + *-gdk-error-code* + (cffi:with-foreign-pointer-as-string (buf 64) + #-(or win32 windows mswindows) + (XGetErrorText *gdk-display* *-gdk-error-code* buf 63))) + (setf *-gdk-error-code* 0))) + ;; thread-safe entry function (defun gtk-main-iteration (port &optional block) (with-gtk () @@ -92,7 +101,8 @@ (if block (gtk_main_iteration_do 1) (while (plusp (gtk_events_pending)) - (gtk_main_iteration_do 0)))))) + (gtk_main_iteration_do 0)))) + (dribble-x-errors))) (defmethod get-next-event ((port gtkairo-port) &key wait-function (timeout nil)) @@ -128,13 +138,29 @@ (define-signal noop-handler (widget event)) (define-signal expose-handler (widget event) - (enqueue - (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) - (gdk_window_clear_area (gtkwidget-gdkwindow widget) x y width height) - (make-instance 'window-repaint-event - :timestamp (get-internal-real-time) - :sheet (widget->sheet widget *port*) - :region (make-rectangle* x y (+ x width) (+ y height)))))) + (let* ((sheet (widget->sheet widget *port*)) + (mirror (climi::port-lookup-mirror *port* sheet))) + (unless + ;; fixme: this shouldn't happen + (typep mirror 'drawable-mirror) + (if (buffering-pixmap-dirty-p mirror) + (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) + (if (mirror-buffering-pixmap mirror) + (setf (buffering-pixmap-dirty-p mirror) nil) + (gdk_window_clear_area (gtkwidget-gdkwindow widget) + x y + width height)) + (enqueue + (make-instance 'window-repaint-event + :timestamp (get-internal-real-time) + :sheet (widget->sheet widget *port*) + :region (make-rectangle* x y (+ x width) (+ y height))))) + (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) + (let* ((from (mirror-buffering-pixmap mirror)) + (to (gtkwidget-gdkwindow (mirror-widget mirror))) + (gc (gdk_gc_new to))) + (gdk_draw_drawable to gc from x y x y width height) + (gdk_gc_unref gc))))))) (defun gdkmodifiertype->modifier-state (state) (logior @@ -246,6 +272,11 @@ (define-signal enter-handler (widget event) (cffi:with-foreign-slots ((time state x y x_root y_root) event gdkeventcrossing) + ;; The frontend sets p-p-s for us, but apparently that sometimes + ;; happens too late, leaving NIL in the slot. Test case is the Drag and + ;; Drop demo. (Even weirder: Starting it from demodemo for a second time + ;; makes the problem go away, only the first invocation has this problem.) + (setf (climi::port-pointer-sheet *port*) (widget->sheet widget *port*)) (enqueue (make-instance 'pointer-enter-event :pointer 0 --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/05/13 19:37:29 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 17:22:23 1.8 @@ -120,6 +120,19 @@ (gdk_threads_leave))))) +;;; Error handling: + +(cffi:defcvar "_gdk_error_warnings" :int) +(cffi:defcvar "_gdk_error_code" :int) + +(cffi:defcfun "XGetErrorText" + :void + (display :pointer) + (code :int) + (buf :pointer) + (length :int)) + + ;;; GROVELME ;; must be a separate structure definition in order for padding on AMD64 @@ -730,6 +743,12 @@ (width :int) (height :int)) +(defcfun "gdk_window_invalidate_rect" + :void + (window :pointer) + (rect :pointer) + (childrenp :int)) + (defconstant GDK_EXPOSURE_MASK (ash 1 1)) (defconstant GDK_POINTER_MOTION_MASK (ash 1 2)) (defconstant GDK_POINTER_MOTION_HINT_MASK (ash 1 3)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/06/10 10:08:49 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/05 17:22:23 1.9 @@ -75,6 +75,8 @@ (sheet-region (medium-sheet medium))))))) (defun sync-sheet (medium) + (when (medium-sheet medium) ;ignore the metrik-medium + (setf (gethash medium (dirty-mediums (port medium))) t)) (when (or (null (cr medium)) (sheet-changed-behind-our-back-p medium)) (with-cairo-medium (medium) @@ -121,6 +123,10 @@ (setf tr (compose-transformations extra-transformation tr))) (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation tr) + ;; Make sure not to hand transformations to cairo that it won't + ;; like, since debugging gets ugly once a cairo context goes + ;; into an error state: + (invert-transformation tr) (cairo_matrix_init matrix (df mxx) (df mxy) (df myx) (df myy) (df tx) (df ty)) @@ -238,21 +244,18 @@ (setf (flipping-original-cr medium) (cr medium)) (let* ((mirror (medium-mirror medium)) (drawable (mirror-drawable mirror))) - (cffi:with-foreign-slots ((allocation-width allocation-height) - (mirror-widget mirror) - gtkwidget) - (let* ((region (climi::sheet-mirror-region (medium-sheet medium))) - (width (floor (bounding-rectangle-max-x region))) - (height (floor (bounding-rectangle-max-y region))) - (pixmap - (or (flipping-pixmap medium) - (setf (flipping-pixmap medium) - (gdk_pixmap_new drawable width height -1))))) - (setf (cr medium) (gdk_cairo_create pixmap)) - (setf (flipping-region medium) region) - (cairo_paint (cr medium)) - (sync-transformation medium) - (sync-ink medium +white+))))) + (let* ((region (climi::sheet-mirror-region (medium-sheet medium))) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region))) + (pixmap + (or (flipping-pixmap medium) + (setf (flipping-pixmap medium) + (gdk_pixmap_new drawable width height -1))))) + (setf (cr medium) (gdk_cairo_create pixmap)) + (setf (flipping-region medium) region) + (cairo_paint (cr medium)) + (sync-transformation medium) + (sync-ink medium +white+)))) (defmethod sync-ink (medium new-value) (warn "SYNC-INK lost ~S." new-value)) @@ -639,12 +642,30 @@ (defmethod medium-finish-output ((medium gtkairo-medium)) (with-cairo-medium (medium) (when (cr medium) - (cairo_surface_flush (cairo_get_target (cr medium)))))) + (cairo_surface_flush (cairo_get_target (cr medium))))) + (medium-force-output medium)) (defmethod medium-force-output ((medium gtkairo-medium)) + (remhash medium (dirty-mediums (port medium))) (with-cairo-medium (medium) (when (cr medium) - (cairo_surface_flush (cairo_get_target (cr medium)))))) + (cairo_surface_flush (cairo_get_target (cr medium))) + (invalidate-mirror (medium-mirror medium) (medium-sheet medium))))) + +(defmethod invalidate-mirror ((mirror drawable-mirror) sheet) + (declare (ignore sheet))) + +(defmethod invalidate-mirror ((mirror widget-mirror) sheet) + (let* ((drawable (mirror-drawable mirror)) + (real-drawable (mirror-real-drawable mirror))) + (unless (cffi:pointer-eq drawable real-drawable) + (let* ((region (climi::sheet-mirror-region sheet)) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region)))) + (cffi:with-foreign-object (r 'gdkrectangle) + (setf (cffi:foreign-slot-value r 'gdkrectangle 'width) width) + (setf (cffi:foreign-slot-value r 'gdkrectangle 'height) height) + (gdk_window_invalidate_rect real-drawable r 0)))))) (defmethod medium-beep ((medium gtkairo-medium)) ;; fixme: visual beep? --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/05/13 19:37:29 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/05 17:22:23 1.5 @@ -47,7 +47,9 @@ (events-head :accessor events-head) (events-tail :accessor events-tail) (widgets->sheets :initform (make-hash-table) :accessor widgets->sheets) - (metrik-medium :accessor metrik-medium))) + (dirty-mediums :initform (make-hash-table) :accessor dirty-mediums) + (metrik-medium :accessor metrik-medium) + (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil))) ;;;(defmethod print-object ((object gtkairo-port) stream) ;;; (print-unreadable-object (object stream :identity t :type t) @@ -72,7 +74,8 @@ (slot-value port 'climi::frame-managers)) (when (zerop *g-threads-got-initialized*) (g_thread_init (cffi:null-pointer)) - (gdk_threads_init)) + (gdk_threads_init) + (setf *-gdk-error-warnings* 0)) (with-gtk () ;; FIXME: hier koennten wir mindestens ein anderes --display uebergeben ;; wenn wir wollten @@ -106,8 +109,13 @@ (region :initform nil :accessor mirror-region))) (defclass widget-mirror (mirror) - ((widget :initarg :widget :accessor mirror-widget) - (mediums :initform '() :accessor mirror-mediums))) + ((port :initarg :port :accessor mirror-port) + (widget :initarg :widget :accessor mirror-widget) + (mediums :initform '() :accessor mirror-mediums) + (buffering-pixmap-dirty-p + :initform t + :accessor buffering-pixmap-dirty-p) + (buffering-pixmap :initform nil :accessor mirror-buffering-pixmap))) (defclass window-mirror (widget-mirror) ((window :initarg :window :accessor mirror-window))) @@ -116,12 +124,42 @@ ((fixed :initarg :fixed :accessor mirror-fixed))) (defclass drawable-mirror (mirror) - ((drawable :initarg :drawable :accessor mirror-drawable) + ((drawable :initarg :drawable + :accessor mirror-drawable + :accessor mirror-real-drawable) (mediums :initform '() :accessor mirror-mediums))) -(defmethod mirror-drawable ((mirror widget-mirror)) +(defmethod mirror-real-drawable ((mirror widget-mirror)) (gtkwidget-gdkwindow (mirror-widget mirror))) +(defvar *double-buffering-p* t) + +(defparameter *old-frontend-size-hack* t) + +(defmethod mirror-drawable ((mirror widget-mirror)) + (if *double-buffering-p* + (or (mirror-buffering-pixmap mirror) + (setf (mirror-buffering-pixmap mirror) + (let* ((*old-frontend-size-hack* nil) + (window (mirror-real-drawable mirror)) + (region (climi::sheet-mirror-region + (climi::port-lookup-sheet + (mirror-port mirror) + mirror))) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region))) + (pixmap (gdk_pixmap_new window width height -1)) + (cr (gdk_cairo_create pixmap))) + (cairo_set_source_rgba cr + 1.0d0 + 1.0d0 + 1.0d0 + 1.0d0) + (cairo_paint cr) + (cairo_destroy cr) + pixmap))) + (mirror-real-drawable mirror))) + (defun widget->sheet (widget port) (gethash (cffi:pointer-address widget) (widgets->sheets port))) @@ -160,7 +198,10 @@ (widget (gtk_fixed_new)) (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) - (mirror (make-instance 'window-mirror :window window :widget widget))) + (mirror (make-instance 'window-mirror + :port port + :window window + :widget widget))) (gtk_window_set_title window (frame-pretty-name (pane-frame sheet))) (setf (widget->sheet widget port) sheet) (setf (widget->sheet window port) sheet) @@ -216,7 +257,7 @@ (widget (gtk_fixed_new)) (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) - (mirror (make-instance 'widget-mirror :widget widget))) + (mirror (make-instance 'widget-mirror :port port :widget widget))) (setf (widget->sheet widget port) sheet) ;; Das machen wir uns mal einfach und geben jedem Widget sein eigenes ;; Fenster, dann haben wir naemlich das Koordinatensystem und Clipping @@ -266,7 +307,10 @@ (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) (mirror - (make-instance 'native-widget-mirror :fixed fixed :widget widget))) + (make-instance 'native-widget-mirror + :port port + :fixed fixed + :widget widget))) (setf (widget->sheet fixed port) sheet) (setf (widget->sheet widget port) sheet) (gtk_fixed_set_has_window fixed 1) @@ -376,6 +420,8 @@ (let ((mirror (climi::port-lookup-mirror port sheet))) (destroy-mediums mirror) (gtk_widget_destroy (mirror-widget mirror)) + (when (mirror-buffering-pixmap mirror) + (gdk_drawable_unref (mirror-drawable mirror))) (climi::port-unregister-mirror port sheet mirror) (setf (widget->sheet (mirror-widget mirror) port) nil)))) @@ -408,15 +454,25 @@ (defun reset-mediums (mirror) (dolist (medium (mirror-mediums mirror)) - (setf (cr medium) nil))) + (setf (cr medium) nil)) + (when (mirror-buffering-pixmap mirror) + (let* ((old (mirror-buffering-pixmap mirror)) + (new (progn + (setf (mirror-buffering-pixmap mirror) nil) + (mirror-drawable mirror))) + (gc (gdk_gc_new new))) + (gdk_draw_drawable new gc old 0 0 0 0 -1 -1) + (gdk_gc_unref gc) + (gdk_drawable_unref old)) + (setf (buffering-pixmap-dirty-p mirror) t))) (defmethod port-set-mirror-region ((port gtkairo-port) (mirror window-mirror) mirror-region) (with-gtk () - (reset-mediums mirror) (gtk_window_resize (mirror-window mirror) (floor (bounding-rectangle-max-x mirror-region)) (floor (bounding-rectangle-max-y mirror-region))) + (reset-mediums mirror) ;; Nanu, ohne die Geometrie hier zu korrigieren kann das Fenster nur ;; vergroessert, nicht aber wieder verkleinert werden. (cffi:with-foreign-object (geometry 'gdkgeometry) @@ -432,11 +488,11 @@ (unless (and (mirror-region mirror) (region-equal (mirror-region mirror) mirror-region)) (with-gtk () - (reset-mediums mirror) (gtk_widget_set_size_request (mirror-widget mirror) (floor (bounding-rectangle-max-x mirror-region)) - (floor (bounding-rectangle-max-y mirror-region)))) + (floor (bounding-rectangle-max-y mirror-region))) + (reset-mediums mirror)) (setf (mirror-region mirror) mirror-region))) (defmethod port-set-mirror-region @@ -452,7 +508,8 @@ (with-gtk () (multiple-value-bind (x y) (transform-position mirror-transformation 0 0) - (gtk_window_move (mirror-window mirror) (floor x) (floor y))))) + (gtk_window_move (mirror-window mirror) (floor x) (floor y))) + (reset-mediums mirror))) (defmethod port-set-mirror-transformation ((port gtkairo-port) (mirror mirror) mirror-transformation) @@ -578,10 +635,28 @@ (error "port-string-width called, what now?")) (defmethod port-mirror-width ((port gtkairo-port) sheet) - (error "port-mirror-width called, we thought the frontend doesn't do that")) + (if *old-frontend-size-hack* + #x10000 + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request + (mirror-widget (climi::port-lookup-mirror port sheet)) + r) + (cffi:foreign-slot-value r 'gtkrequisition 'width)))) (defmethod port-mirror-height ((port gtkairo-port) sheet) - (error "port-mirror-height called, we thought the frontend doesn't do that")) + (if *old-frontend-size-hack* + #x10000 + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request + (mirror-widget (climi::port-lookup-mirror port sheet)) + r) + (cffi:foreign-slot-value r 'gtkrequisition 'height)))) + +(defmethod port-mirror-width ((port gtkairo-port) (sheet gtkairo-graft)) + (graft-width sheet)) + +(defmethod port-mirror-height ((port gtkairo-port) (sheet gtkairo-graft)) + (graft-height sheet)) (defmethod graft ((port gtkairo-port)) (first (climi::port-grafts port))) @@ -655,11 +730,15 @@ (defmethod port-force-output ((port gtkairo-port)) (with-gtk () + (loop + for medium being each hash-key in (dirty-mediums port) + do (medium-force-output medium)) (gdk_display_flush (gdk_display_get_default)) ;; Don't know whether p-f-o is actually meant to XSync, which is ;; what gdk_flush does. But it seems useful to have _some_ function ;; for this, so let's use p-f-o until we find a better one. - (gdk_flush))) + (gdk_flush) + (dribble-x-errors))) ;; FIXME: What happens when CLIM code calls tracking-pointer recursively? (defmethod port-grab-pointer ((port gtkairo-port) pointer sheet) @@ -680,15 +759,21 @@ ;;; (tr :timeout!) ;;; (with-gtk () ;;; (gdk_pointer_ungrab GDK_CURRENT_TIME)))) - (zerop status)))) + (when (zerop status) + (setf (pointer-grab-sheet port) sheet))))) (defmethod port-ungrab-pointer ((port gtkairo-port) pointer sheet) (declare (ignore pointer sheet)) (with-gtk () - (gdk_pointer_ungrab GDK_CURRENT_TIME))) + (when (eq (pointer-grab-sheet port) sheet) + (gdk_pointer_ungrab GDK_CURRENT_TIME) + (setf (pointer-grab-sheet port) nil)))) (defmethod distribute-event :around ((port gtkairo-port) event) - (call-next-method)) + (let ((grab-sheet (pointer-grab-sheet port))) + (if grab-sheet + (queue-event grab-sheet event) + (call-next-method)))) (defmethod set-sheet-pointer-cursor ((port gtkairo-port) sheet cursor) ())

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs