Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv11024

Modified Files: base.lisp gui.lisp syntax.lisp Log Message: performance improvements.

Date: Mon Dec 27 12:32:46 2004 Author: rstrandh

Index: climacs/base.lisp diff -u climacs/base.lisp:1.5 climacs/base.lisp:1.6 --- climacs/base.lisp:1.5 Sun Dec 26 08:18:01 2004 +++ climacs/base.lisp Mon Dec 27 12:32:46 2004 @@ -66,14 +66,12 @@ (end-of-line mark) (delete-region offset mark))))

-(defun buffer-number-of-lines-in-region (mark1 mark2) - "Helper function for number-of-lines-in-region. Moves the position -of mark1 until it is greater than or equal to that of mark2 and counts -Newline characters along the way" - (loop do (end-of-line mark1) - while (mark< mark1 mark2) - count t - do (incf (offset mark1)))) +(defun buffer-number-of-lines-in-region (buffer offset1 offset2) + "Helper function for number-of-lines-in-region. Count newline +characters in the region between offset1 and offset2" + (loop while (< offset1 offset2) + count (eql (buffer-object buffer offset1) #\Newline) + do (incf offset1)))

(defgeneric number-of-lines-in-region (mark1 mark2) (:documentation "Return the number of lines (or rather the number of @@ -81,21 +79,13 @@ acceptable to pass an offset in place of one of the marks"))

(defmethod number-of-lines-in-region ((mark1 mark) (mark2 mark)) - (buffer-number-of-lines-in-region (clone-mark mark1) mark2)) + (buffer-number-of-lines-in-region (buffer mark1) (offset mark1) (offset mark2)))

(defmethod number-of-lines-in-region ((offset integer) (mark mark)) - (buffer-number-of-lines-in-region - (make-instance 'standard-left-sticky-mark - :buffer (buffer mark) - :offset offset) - mark)) + (buffer-number-of-lines-in-region (buffer mark) offset (offset mark)))

(defmethod number-of-lines-in-region ((mark mark) (offset integer)) - (buffer-number-of-lines-in-region - (clone-mark mark) - (make-instance 'standard-left-sticky-mark - :buffer (buffer mark) - :offset offset))) + (buffer-number-of-lines-in-region (buffer mark) (offset mark) offset))

(defun constituentp (obj) "A predicate to ensure that an object is a constituent character."

Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.19 climacs/gui.lisp:1.20 --- climacs/gui.lisp:1.19 Mon Dec 27 06:58:29 2004 +++ climacs/gui.lisp Mon Dec 27 12:32:46 2004 @@ -48,6 +48,7 @@ (win (make-pane 'climacs-pane :width 900 :height 400 :name 'win +;;; :incremental-redisplay t :display-function 'display-win)) (int :interactor :width 900 :height 50 :max-height 50)) (:layouts @@ -114,7 +115,7 @@ (format *error-output* "~a~%" condition))) (setf gestures '())) (t nil)))) - (redisplay-frame-panes frame :force-p t)))) + (redisplay-frame-panes frame))))

(define-command com-quit () (frame-exit *application-frame*))

Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.7 climacs/syntax.lisp:1.8 --- climacs/syntax.lisp:1.7 Mon Dec 27 05:32:44 2004 +++ climacs/syntax.lisp Mon Dec 27 12:32:46 2004 @@ -49,8 +49,7 @@ (let ((buffer (buffer pane))) (with-slots (top bot scan space-width tab-width) syntax (setf top (make-instance 'standard-left-sticky-mark :buffer buffer) - bot (make-instance 'standard-right-sticky-mark :buffer buffer) - scan (make-instance 'standard-left-sticky-mark :buffer buffer)) + bot (make-instance 'standard-right-sticky-mark :buffer buffer)) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium))) (setf space-width (text-style-width style medium) @@ -67,27 +66,39 @@ 'string) :stream pane)))

+(defmacro maybe-updating-output (stuff &body body) + `(progn ,@body)) + +;; (defmacro maybe-updating-output (stuff &body body) +;; `(updating-output ,stuff ,@body)) + (defmethod display-line (pane (syntax basic-syntax)) (with-slots (saved-offset bot scan cursor-x cursor-y space-width tab-width) syntax (flet ((compute-contents () (unless (null saved-offset) - (prog1 (coerce (region-to-sequence saved-offset scan) 'string) + (prog1 (coerce (buffer-sequence (buffer pane) saved-offset scan) 'string) (setf saved-offset nil))))) (macrolet ((output-word (&body body) `(let ((contents (compute-contents))) - (present-contents contents pane syntax) - ,@body))) - (loop when (mark= scan (point pane)) + (if (null contents) + (progn ,@body) + (maybe-updating-output (pane :unique-id (incf id) + :cache-value contents + :cache-test #'string=) + (present-contents contents pane syntax) + ,@body))))) + (loop with id = 0 + when (mark= scan (point pane)) do (multiple-value-bind (x y) (stream-cursor-position pane) (setf cursor-x (+ x (if (null saved-offset) 0 - (* space-width (- (offset scan) saved-offset)))) + (* space-width (- scan saved-offset)))) cursor-y y)) when (mark= scan bot) do (output-word) (return) - until (eql (object-after scan) #\Newline) - do (let ((obj (object-after scan))) + until (eql (buffer-object (buffer pane) scan) #\Newline) + do (let ((obj (buffer-object (buffer pane) scan))) (cond ((eql obj #\Space) (output-word (princ obj pane))) ((eql obj #\Tab) @@ -97,13 +108,12 @@ pane (- tab-width (mod x tab-width)) 0))) ((constituentp obj) (when (null saved-offset) - (setf saved-offset (offset scan)))) + (setf saved-offset scan))) (t (output-word (princ obj pane))))) - (incf (offset scan)) - finally (output-word) - (incf (offset scan)) - (terpri pane)))))) + (incf scan) + finally (output-word (terpri pane)) + (incf scan))))))

(defmethod redisplay-with-syntax (pane (syntax basic-syntax)) (let* ((medium (sheet-medium pane)) @@ -138,9 +148,11 @@ until (end-of-buffer-p bot) do (incf (offset bot)) (end-of-line bot))) - (setf (offset scan) (offset top)) - (loop until (mark= scan bot) - do (display-line pane syntax)) + (setf scan (offset top)) + (loop for id from 0 + until (mark= scan bot) + do (maybe-updating-output (pane :unique-id id) + (display-line pane syntax))) (when (mark= scan (point pane)) (multiple-value-bind (x y) (stream-cursor-position pane) (setf cursor-x x