Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv2159

Modified Files: window-commands.lisp Log Message: Hmm, guess I forgot to commit the meat of typeout pane-scrolling.

--- /project/climacs/cvsroot/climacs/window-commands.lisp 2007/12/27 16:28:08 1.16 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2008/01/06 11:47:37 1.17 @@ -152,10 +152,26 @@ 'window-table '((#\x :control) (#\1)))

+(defun scroll-typeout-window (window y) + "Scroll `window' down by `y' device units, but taking care not +to scroll past the size of `window'. If `window' does not have a +viewport, do nothing." + (let ((viewport (pane-viewport window))) + (unless (null viewport) ; Can't scroll without viewport + (multiple-value-bind (x-displacement y-displacement) + (transform-position (sheet-transformation window) 0 0) + (scroll-extent window + (- x-displacement) + (max 0 (min (+ (- y-displacement) y) + (- (bounding-rectangle-height window) + (bounding-rectangle-height viewport))))))))) + (define-command (com-scroll-other-window :name t :command-table window-table) () (let ((other-window (second (windows *application-frame*)))) (when other-window - (page-down (view other-window))))) + (if (typeout-pane-p other-window) + (scroll-typeout-window other-window (bounding-rectangle-height (pane-viewport other-window))) + (page-down (view other-window))))))

(set-key 'com-scroll-other-window 'window-table @@ -164,7 +180,9 @@ (define-command (com-scroll-other-window-up :name t :command-table window-table) () (let ((other-window (second (windows *application-frame*)))) (when other-window - (page-up (view other-window))))) + (if (typeout-pane-p other-window) + (scroll-typeout-window other-window (- (bounding-rectangle-height (pane-viewport other-window)))) + (page-up (view other-window))))))

(set-key 'com-scroll-other-window-up 'window-table