mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim
by rstrandh 16 Oct '09

16 Oct '09

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv15495 Modified Files: dialog.lisp Log Message: Fixed problem with Cancel button in accepting-values. Thanks to Kilian Sprotte for the patch. --- /project/mcclim/cvsroot/mcclim/dialog.lisp 2009/08/01 22:17:02 1.32 +++ /project/mcclim/cvsroot/mcclim/dialog.lisp 2009/10/16 04:57:00 1.33 @@ -271,12 +271,11 @@ (format stream "OK")))) (formatting-cell (stream) (with-output-as-presentation - (stream nil 'abort-button) (with-output-as-presentation - (stream nil 'exit-button) + (stream nil 'abort-button) (surrounding-output-with-border - (stream :shape :rounded :radius 6 - :background +gray80+ :highlight-background +gray90+) - (format stream "Cancel"))))))) + (stream :shape :rounded :radius 6 + :background +gray80+ :highlight-background +gray90+) + (format stream "Cancel")))))) (terpri stream))) (defmethod stream-accept ((stream accepting-values-stream) type

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by rstrandh 02 Sep '09

02 Sep '09

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory cl-net:/tmp/cvs-serv21922 Modified Files: cairo.lisp ffi.lisp Log Message: Added support for image design drawing in the gtkairo backend. Thanks to Samium Gromoff for contributing this patch. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2007/07/11 15:26:20 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp 2009/09/02 05:29:01 1.5 @@ -534,6 +534,103 @@ (cairo_move_to cr (df x) (df (+ y y2)))) (pango_cairo_show_layout cr layout)))))) +;; Stolen from the CLX backend. +(defmethod climi::medium-draw-image-design* + ((medium cairo-medium) (design climi::rgb-image-design) x y) + (destructuring-bind (&optional surface buffer mask) + (slot-value design 'climi::medium-data) + (unless surface + (let* ((image (slot-value design 'climi::image))) + (setf (values surface buffer) (image-to-cairosurface image)) + (when (climi::image-alpha-p image) + (error "~@<Drawing of images with alpha component is not supported.~:@>")) + (setf (slot-value design 'climi::medium-data) (list surface buffer mask)))) + (when mask + (error "~@<A mask in your image design.~:@>")) + (with-medium (medium) + (multiple-value-bind (x y) + (transform-position + (sheet-device-transformation (medium-sheet medium)) + x y) + (setf x (float x 0d0)) + (setf y (float y 0d0)) + (with-slots (cr) medium + (cairo_set_source_surface cr surface x y) + (cond + #+ (or) + (mask + (xlib:with-gcontext (gcontext + :clip-mask mask + :clip-x x + :clip-y y) + (xlib:copy-area pixmap gcontext 0 0 width height + da x y))) + (t + (cairo_paint cr)))))))) + +(defmethod climi::medium-free-image-design + ((medium cairo-medium) (design climi::rgb-image-design)) + (destructuring-bind (&optional surface buffer mask) + (slot-value design 'climi::medium-data) + (when surface + #+ (or) + ;; This one bites, no idea why. + (cairo_destroy surface) + (cffi:foreign-free buffer) + (setf (slot-value design 'climi::medium-data) nil)))) + +;; Was: CLX/compute-rgb-image-mask +#+ (or) +(defun compute-rgb-image-mask (drawable image) + (let* ((width (climi::image-width image)) + (height (climi::image-height image)) + (bitmap (xlib:create-pixmap :drawable drawable + :width width + :height height + :depth 1)) + (gc (xlib:create-gcontext :drawable bitmap + :foreground 1 + :background 0)) + (idata (climi::image-data image)) + (xdata (make-array (list height width) + :element-type '(unsigned-byte 1))) + (im (xlib:create-image :width width + :height height + :depth 1 + :data xdata)) ) + (dotimes (y width) + (dotimes (x height) + (if (> (aref idata x y) #x80000000) + (setf (aref xdata x y) 0) + (setf (aref xdata x y) 1)))) + (unless (or (>= width 2048) (>= height 2048)) ;### CLX breaks here + (xlib:put-image bitmap gc im :src-x 0 :src-y 0 + :x 0 :y 0 :width width :height height + :bitmap-p nil)) + (xlib:free-gcontext gc) + bitmap)) + +;; Was: CLX/image-to-ximage +(defun image-to-cairosurface (image) + (let* ((width (climi::image-width image)) + (height (climi::image-height image)) + (idata (climi::image-data image)) + (stride (cairo_format_stride_for_width :rgb24 width)) + (cairodata (cffi:foreign-alloc :uint8 :count (* stride height)))) + (declare (type (simple-array (unsigned-byte 32) (* *)) idata)) + (loop :for row-offset :from 0 :by stride + :for y :from 0 :below height + :do (loop :for offset :from row-offset :by 4 + :for x :from 0 :below width + :do (let ((px (aref idata y x))) + (setf (cffi:mem-ref cairodata :uint32 offset) + (dpb (ldb (byte 8 0) px) (byte 8 16) + (dpb (ldb (byte 8 8) px) (byte 8 8) + (dpb (ldb (byte 8 16) px) (byte 8 0) + 0))))))) + (values (cairo_image_surface_create_for_data cairodata :rgb24 width height stride) + cairodata))) + (defmethod medium-finish-output ((medium cairo-medium)) (with-medium (medium) (when (cr medium) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2007/03/03 12:09:51 1.18 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2009/09/02 05:29:01 1.19 @@ -333,6 +333,12 @@ (arg0 :pointer) ;cairo_font_face_t * ) +(defcfun "cairo_format_stride_for_width" + :int + (arg0 cairo_format_t) + (arg1 :int) + ) + (defcfun "cairo_get_font_face" :pointer (arg0 :pointer) ;cairo_t * @@ -643,6 +649,14 @@ (arg4 :double) ;double ) +(defcfun "cairo_set_source_surface" + :void + (arg0 :pointer) ;cairo_t * + (arg1 :pointer) ;cairo_surface_t * + (arg2 :double) + (arg3 :double) + ) + (defcfun "cairo_set_tolerance" :void (arg0 :pointer) ;cairo_t *

1 0

[mcclim-cvs] CVS mcclim
by rstrandh 02 Sep '09

02 Sep '09

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv15355 Added Files: mcclim-png-bitmaps.asd Log Message: Added support for reading PNG files contributed by Samium Gromoff. Thanks! --- /project/mcclim/cvsroot/mcclim/mcclim-png-bitmaps.asd 2009/09/02 05:20:40 NONE +++ /project/mcclim/cvsroot/mcclim/mcclim-png-bitmaps.asd 2009/09/02 05:20:40 1.1 ;;; -*- Mode: Lisp -*- ;;; (c) copyright 2009 by ;;; Samium Gromoff (_deepfire(a)feelingofgreen.ru) ;;; ;;; 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. (asdf:defsystem :mcclim-png-bitmaps :description "Support for PNG images in McCLIM bitmap reading functions." :depends-on (:mcclim :png-read) :components ((:file "png" :pathname #P"Extensions/Bitmap-formats/png")))

1 0

[mcclim-cvs] CVS mcclim/Extensions/Bitmap-formats
by rstrandh 02 Sep '09

02 Sep '09

Update of /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats In directory cl-net:/tmp/cvs-serv15355/Extensions/Bitmap-formats Added Files: png.lisp Log Message: Added support for reading PNG files contributed by Samium Gromoff. Thanks! --- /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/png.lisp 2009/09/02 05:20:40 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/png.lisp 2009/09/02 05:20:40 1.1 ;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2009 by ;;; Samium Gromoff (_deepfire(a)feelingofgreen.ru) ;;; 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. (in-package :clim-internals) (define-bitmap-file-reader :png (image-pathname) (let* ((png-state (png-read:read-png-file image-pathname)) (data (png-read:image-data png-state)) (depth (png-read:bit-depth png-state)) (height (png-read:height png-state)) (width (png-read:width png-state)) (array (make-array (list height width) :element-type '(unsigned-byte 32)))) (unless (member depth '(8 32)) (error "~@<PNG-encoded images with bit depth ~D are not supported. The only supported bit depths are 8 and 32.~:@>" depth)) (dotimes (y height) (dotimes (x width) (case depth ((8 32) (let ((red (aref data x y 0)) (green (aref data x y 1)) (blue (aref data x y 2))) (setf (aref array y x) (dpb red (byte 8 0) (dpb green (byte 8 8) (dpb blue (byte 8 16) (dpb (- 255 0) (byte 8 24) 0)))))))))) array))

1 0

[mcclim-cvs] CVS mcclim
by gbaumann 01 Aug '09

01 Aug '09

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv16322 Modified Files: dialog.lisp Log Message: FRAME-MANAGER-NOTIFY-USER Use :calling-frame, leave shareing the event queue to the calling frame to what ever magic does it correctly in that case. --- /project/mcclim/cvsroot/mcclim/dialog.lisp 2008/12/07 03:22:54 1.31 +++ /project/mcclim/cvsroot/mcclim/dialog.lisp 2009/08/01 22:17:02 1.32 @@ -737,7 +737,7 @@ ;; Keywords from notify-user: ;; associated-window title documentation exit-boxes name style text-style (let ((frame (make-application-frame 'generic-notify-user-frame - :frame-event-queue (and frame (frame-event-queue frame)) + :calling-frame frame :pretty-name title :message-string message-string :frame-manager frame-manager

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by gbaumann 01 Aug '09

01 Aug '09

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory cl-net:/tmp/cvs-serv16195 Modified Files: frame-manager.lisp Log Message: (ADOPT-FRAME :AFTER CLX-FRAME-MANAGER APPLICATION-FRAME) If the frame happens to have a non-null calling-frame slot, tell the window manager. That way pop up dialogs are recognized as such allowing the window manager to apply what ever special handling it does to pop up windows. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/frame-manager.lisp 2009/01/28 19:27:22 1.23 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/frame-manager.lisp 2009/08/01 22:15:32 1.24 @@ -117,6 +117,14 @@ (setf (xlib:window-event-mask mirror) (logior (xlib:window-event-mask mirror) (xlib:make-event-mask :structure-notify))) + ;; Care for calling-frame, be careful not to trip on missing bits + (let* ((calling-frame (frame-calling-frame frame)) + (tls (and calling-frame (frame-top-level-sheet calling-frame))) + (calling-mirror (and tls (sheet-mirror tls)))) + (when calling-mirror + (setf (xlib:transient-for mirror) + calling-mirror))) + ;; (when (sheet-enabled-p sheet) (xlib:map-window mirror) ))))

1 0

[mcclim-cvs] CVS mcclim
by gbaumann 01 Aug '09

01 Aug '09

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv15258 Modified Files: panes.lisp Log Message: (ALLOCATE-SPACE SCROLLER-PANE T T) Missed one *SCROLLBAR-THICKNESS* SCROLL-AREA Removed this ticking bomb. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2009/08/01 21:27:13 1.196 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2009/08/01 22:11:06 1.197 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.196 2009/08/01 21:27:13 gbaumann Exp $ +;;; $Id: panes.lisp,v 1.197 2009/08/01 22:11:06 gbaumann Exp $ (in-package :clim-internals) @@ -2060,7 +2060,7 @@ (ecase vertical-scroll-bar-position (:left vsbar-width) (:right 0)) - (- height *scrollbar-thickness*)) + (- height hsbar-height)) (allocate-space hscrollbar (- width vsbar-width) hsbar-height)) @@ -2646,19 +2646,6 @@ (scroll-extent pane x y) (values x y)) -;; this function appears to be unused, however... -;; v-- does this handle scrolling with occlusion? ie, if another thing is overlapping -;; the area being scrolled, will we copy junk off the top? -- BTS -(defun scroll-area (pane dx dy) - (let ((transform (sheet-transformation pane))) - ;; Region has been "scrolled" already. - (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) - (multiple-value-bind (srcx srcy) - (untransform-position transform 0 0) - (multiple-value-bind (destx desty) - (untransform-position transform dx dy) - (copy-area pane srcx srcy (- x2 x1) (- y2 y1) destx desty)))))) - (defmethod stream-set-input-focus ((stream clim-stream-pane)) (with-slots (port) stream (prog1 (port-keyboard-input-focus port)

1 0

[mcclim-cvs] CVS mcclim
by gbaumann 01 Aug '09

01 Aug '09

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv4992 Modified Files: package.lisp panes.lisp Log Message: I like my scroll bars left, Hefner wants them right. So I made it tweakable. Default is right though. CLIM-EXTENSIONS:*DEFAULT-VERTICAL-SCROLL-BAR-POSITION* New variable^Wparameter intented to be settable by the user. VERTICAL-SCROLL-BAR-POSITION slot of SCROLLER-PANE :VERTICAL-SCROLL-BAR-POSITION init arg of SCROLLER-PANE New. (ALLOCATE-SPACE SCROLLER-PANE T T) Use it. Do not use *SCROLLBAR-THICKNESS*, but rely on the space requirements of the scroll bars. --- /project/mcclim/cvsroot/mcclim/package.lisp 2009/08/01 16:10:32 1.71 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2009/08/01 21:27:13 1.72 @@ -1973,7 +1973,8 @@ #:define-bitmap-file-reader #:unsupported-bitmap-format - #:bitmap-format)) + #:bitmap-format + #:*default-vertical-scroll-bar-position*)) ;;; Symbols that must be defined by a backend. ;;; --- /project/mcclim/cvsroot/mcclim/panes.lisp 2009/06/03 20:33:16 1.195 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2009/08/01 21:27:13 1.196 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.195 2009/06/03 20:33:16 ahefner Exp $ +;;; $Id: panes.lisp,v 1.196 2009/08/01 21:27:13 gbaumann Exp $ (in-package :clim-internals) @@ -1929,6 +1929,13 @@ (defparameter *scrollbar-thickness* 17) +(defvar clim-extensions:*default-vertical-scroll-bar-position* + :right + "Default for the :VERTICAL-SCROLL-BAR-POSITION init arg of a + SCROLLER-PANE. Set it to :LEFT to have the vertical scroll bar of a + SCROLLER-PANE appear on the ergonomic left hand side, or leave set to + :RIGHT to have it on the distant right hand side of the scroller.") + (defclass scroller-pane (composite-pane) ((scroll-bar :type scroll-bar-spec ; (member t :vertical :horizontal nil) ;; ### Note: I added NIL here, so that the application @@ -1951,7 +1958,13 @@ (vscrollbar :initform nil) (hscrollbar :initform nil) (suggested-width :initform 300 :initarg :suggested-width) - (suggested-height :initform 300 :initarg :suggested-height)) + (suggested-height :initform 300 :initarg :suggested-height) + (vertical-scroll-bar-position + :initform clim-extensions:*default-vertical-scroll-bar-position* + :initarg :vertical-scroll-bar-position + :type (member :left :right) + :documentation "Whether to put the vertical scroll bar on the left hand or + right hand side of the scroller pane.")) (:default-initargs :x-spacing 4 :y-spacing 4)) @@ -2028,23 +2041,29 @@ (make-space-requirement)))) (defmethod allocate-space ((pane scroller-pane) width height) - (with-slots (viewport vscrollbar hscrollbar x-spacing y-spacing) pane - (let ((viewport-width (if vscrollbar (- width *scrollbar-thickness*) width)) - (viewport-height (if hscrollbar (- height *scrollbar-thickness*) height))) - + (with-slots (viewport vscrollbar hscrollbar x-spacing y-spacing vertical-scroll-bar-position) pane + (let* ((vsbar-width (if vscrollbar (space-requirement-width (compose-space vscrollbar)) 0)) + (hsbar-height (if hscrollbar (space-requirement-height (compose-space hscrollbar)) 0)) + (viewport-width (- width vsbar-width)) + (viewport-height (- height hsbar-height))) (when vscrollbar - (setf (sheet-transformation vscrollbar) - (make-translation-transformation (- width *scrollbar-thickness*) 0)) + (move-sheet vscrollbar + (ecase vertical-scroll-bar-position + (:left 0) + (:right (- width vsbar-width))) + 0) (allocate-space vscrollbar - *scrollbar-thickness* - (if hscrollbar (- height *scrollbar-thickness*) height))) + vsbar-width + (- height hsbar-height))) (when hscrollbar (move-sheet hscrollbar - 0 + (ecase vertical-scroll-bar-position + (:left vsbar-width) + (:right 0)) (- height *scrollbar-thickness*)) (allocate-space hscrollbar - (if vscrollbar (- width *scrollbar-thickness*) width) - *scrollbar-thickness*)) + (- width vsbar-width) + hsbar-height)) ;; ;; Recalculate the gadget-values of the scrollbars ;; @@ -2073,10 +2092,12 @@ max)))) (setf (scroll-bar-values hscrollbar) (values min max ts val)))) (when viewport - (setf (sheet-transformation viewport) - (make-translation-transformation - (+ x-spacing 0) - (+ y-spacing 0))) + (move-sheet viewport + (+ x-spacing + (ecase vertical-scroll-bar-position + (:left vsbar-width) + (:right 0))) + (+ y-spacing 0)) (allocate-space viewport (- viewport-width (* 2 x-spacing)) (- viewport-height (* 2 y-spacing)))))))

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by gbaumann 01 Aug '09

01 Aug '09

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory cl-net:/tmp/cvs-serv2833/Backends/CLX Modified Files: port.lisp Log Message: Use force-output instead of finish-output as the latter implies waiting for an answer from the display server, which is something we really do not want to do. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2009/04/20 10:21:00 1.140 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2009/08/01 16:10:39 1.141 @@ -863,7 +863,7 @@ (port-client-message sheet time type data)) (t (unless (xlib:event-listen (clx-port-display *clx-port*)) - (xlib:display-finish-output (clx-port-display *clx-port*))) + (xlib:display-force-output (clx-port-display *clx-port*))) nil))))) @@ -908,7 +908,7 @@ (let* ((*clx-port* port) (display (clx-port-display port))) (unless (xlib:event-listen display) - (xlib:display-finish-output (clx-port-display port))) + (xlib:display-force-output (clx-port-display port))) ; temporary solution (or (xlib:process-event (clx-port-display port) :timeout timeout :handler #'event-handler :discard-p t) :timeout))) @@ -1386,7 +1386,7 @@ #+nil ; debugging output (progn (describe event *trace-output*) - (finish-output *trace-output*)) + (force-output *trace-output*)) (flet ((send-event (&key target (property property)) ;; debugging output, but the KDE Klipper client turns out ;; to poll other clients for selection, which means it

1 0

[mcclim-cvs] CVS mcclim
by gbaumann 01 Aug '09

01 Aug '09

Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv2833 Modified Files: frames.lisp incremental-redisplay.lisp package.lisp recording.lisp table-formatting.lisp text-selection.lisp Log Message: Use force-output instead of finish-output as the latter implies waiting for an answer from the display server, which is something we really do not want to do. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2009/02/28 16:49:40 1.136 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2009/08/01 16:10:31 1.137 @@ -466,62 +466,62 @@ (defmethod default-frame-top-level ((frame application-frame) &key (command-parser 'command-line-command-parser) - (command-unparser 'command-line-command-unparser) - (partial-command-parser - 'command-line-read-remaining-arguments-for-partial-command) - (prompt "Command: ")) + (command-unparser 'command-line-command-unparser) + (partial-command-parser + 'command-line-read-remaining-arguments-for-partial-command) + (prompt "Command: ")) ;; Give each pane a fresh start first time through. (let ((first-time t)) (loop ;; The variables are rebound each time through the loop because the ;; values of frame-standard-input et al. might be changed by a command. (let* ((*standard-input* (or (frame-standard-input frame) - *standard-input*)) - (*standard-output* (or (frame-standard-output frame) - *standard-output*)) - (query-io (frame-query-io frame)) - (*query-io* (or query-io *query-io*)) - (*pointer-documentation-output* - (frame-pointer-documentation-output frame)) - ;; during development, don't alter *error-output* - ;; (*error-output* (frame-error-output frame)) - (*command-parser* command-parser) - (*command-unparser* command-unparser) - (*partial-command-parser* partial-command-parser) - (interactorp (typep *query-io* 'interactor-pane))) - (restart-case - (progn - (redisplay-frame-panes frame :force-p first-time) - (setq first-time nil) - (if query-io + *standard-input*)) + (*standard-output* (or (frame-standard-output frame) + *standard-output*)) + (query-io (frame-query-io frame)) + (*query-io* (or query-io *query-io*)) + (*pointer-documentation-output* + (frame-pointer-documentation-output frame)) + ;; during development, don't alter *error-output* + ;; (*error-output* (frame-error-output frame)) + (*command-parser* command-parser) + (*command-unparser* command-unparser) + (*partial-command-parser* partial-command-parser) + (interactorp (typep *query-io* 'interactor-pane))) + (restart-case + (progn + (redisplay-frame-panes frame :force-p first-time) + (setq first-time nil) + (if query-io ;; For frames with an interactor: - (progn + (progn ;; Hide cursor, so we don't need to toggle it during ;; command output. - (setf (cursor-visibility (stream-text-cursor *query-io*)) - nil) - (when (and prompt interactorp) - (with-text-style (*query-io* +default-prompt-style+) - (if (stringp prompt) - (write-string prompt *query-io*) - (funcall prompt *query-io* frame)) - (finish-output *query-io*))) - (let ((command (read-frame-command frame - :stream *query-io*))) - (when interactorp - (fresh-line *query-io*)) - (when command - (execute-frame-command frame command)) - (when interactorp - (fresh-line *query-io*)))) + (setf (cursor-visibility (stream-text-cursor *query-io*)) + nil) + (when (and prompt interactorp) + (with-text-style (*query-io* +default-prompt-style+) + (if (stringp prompt) + (write-string prompt *query-io*) + (funcall prompt *query-io* frame)) + (force-output *query-io*))) + (let ((command (read-frame-command frame + :stream *query-io*))) + (when interactorp + (fresh-line *query-io*)) + (when command + (execute-frame-command frame command)) + (when interactorp + (fresh-line *query-io*)))) ;; Frames without an interactor: (let ((command (read-frame-command frame :stream nil))) (when command (execute-frame-command frame command))))) - (abort () - :report "Return to application command loop" - (if interactorp - (format *query-io* "~&Command aborted.~&") - (beep)))))))) + (abort () + :report "Return to application command loop" + (if interactorp + (format *query-io* "~&Command aborted.~&") + (beep)))))))) (defmethod read-frame-command :around ((frame application-frame) &key (stream *standard-input*)) --- /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2006/09/25 00:30:01 1.65 +++ /project/mcclim/cvsroot/mcclim/incremental-redisplay.lisp 2009/08/01 16:10:32 1.66 @@ -513,7 +513,7 @@ (rectangle-edges* sub-record)))) record nil) - (finish-output stream) + (force-output stream) ;; Why is this binding here? We need the "environment" in this call that ;; computes the new records of an outer updating output record to resemble ;; that when a record's contents are computed in invoke-updating-output. @@ -860,7 +860,7 @@ unique-id id-test cache-value cache-test &key (fixed-position nil) (all-new nil) (parent-cache nil)) - (finish-output stream) + (force-output stream) (let ((parent-cache (or parent-cache *current-updating-output* stream))) (when (eq unique-id *no-unique-id*) (setq unique-id (incf (id-counter parent-cache)))) --- /project/mcclim/cvsroot/mcclim/package.lisp 2008/08/21 22:34:28 1.70 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2009/08/01 16:10:32 1.71 @@ -234,7 +234,7 @@ nil))) packages) (progn (format t "~&there is no ~A." name) - (finish-output) + (force-output) nil))) (dump-defpackage (&aux imports export-ansi export-gray) (labels ((push-import-from (symbol package) @@ -255,7 +255,7 @@ (and sym2 (eq res :external)))) ;; (format t "~&;; ~S is patched." sym) - (finish-output) + (force-output) (push-import-from nam :clim-lisp-patch)) (t (setf sym (car sym)) --- /project/mcclim/cvsroot/mcclim/recording.lisp 2009/08/01 05:23:47 1.144 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2009/08/01 16:10:32 1.145 @@ -2292,7 +2292,7 @@ (letf (((stream-current-output-record stream) new-record)) ;; Should we switch on recording? -- APD (funcall continuation stream new-record) - (finish-output stream)) + (force-output stream)) (if parent (add-output-record new-record parent) (stream-add-output-record stream new-record)) @@ -2309,7 +2309,7 @@ (letf (((stream-current-output-record stream) new-record)) ;; Should we switch on recording? -- APD (funcall continuation stream new-record) - (finish-output stream)) + (force-output stream)) (if parent (add-output-record new-record parent) (stream-add-output-record stream new-record)) @@ -2325,7 +2325,7 @@ (letf (((stream-current-output-record stream) new-record) ((stream-cursor-position stream) (values 0 0))) (funcall continuation stream new-record) - (finish-output stream))) + (force-output stream))) new-record)) (defmethod invoke-with-output-to-output-record @@ -2337,7 +2337,7 @@ (letf (((stream-current-output-record stream) new-record) ((stream-cursor-position stream) (values 0 0))) (funcall continuation stream new-record) - (finish-output stream))) + (force-output stream))) new-record)) (defmethod make-design-from-output-record (record) --- /project/mcclim/cvsroot/mcclim/table-formatting.lisp 2008/11/09 19:58:26 1.41 +++ /project/mcclim/cvsroot/mcclim/table-formatting.lisp 2009/08/01 16:10:32 1.42 @@ -319,7 +319,7 @@ (let ((*table-suppress-update* t)) (with-output-recording-options (stream :record t :draw nil) (funcall continuation stream) - (finish-output stream)) + (force-output stream)) (with-output-recording-options (stream :record nil :draw nil) (adjust-table-cells table stream) (when multiple-columns (adjust-multiple-columns table stream)) @@ -427,7 +427,7 @@ (stream-cursor-position stream) (with-output-recording-options (stream :record t :draw nil) (funcall continuation stream) - (finish-output stream)) + (force-output stream)) (adjust-item-list-cells item-list stream) (setf (output-record-position item-list) (stream-cursor-position stream)) --- /project/mcclim/cvsroot/mcclim/text-selection.lisp 2009/06/03 20:33:16 1.8 +++ /project/mcclim/cvsroot/mcclim/text-selection.lisp 2009/08/01 16:10:32 1.9 @@ -289,7 +289,7 @@ (push (setf q (cons y nil)) *lines*)) (push (list x y string ts record full-record) (cdr q))) - (finish-output *trace-output*))) + (force-output *trace-output*))) (setf *lines* (sort (mapcar (lambda (line) (cons (car line)

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