February 2008 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS mcclim
by thenriksen 19 Feb '08

19 Feb '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv11072 Modified Files: gadgets.lisp Log Message: Fixed division-by-zero bug in scrollbar code. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/08/21 22:09:01 1.107 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/02/19 22:26:06 1.108 @@ -1463,7 +1463,7 @@ (let ((ts (scroll-bar-thumb-size sb))) ;; This is the right spot to handle ts = :none or perhaps NIL (multiple-value-bind (range) (gadget-range sb) - (let ((ts-in-pixels (round (* (- y3 y1) (/ ts (+ range ts)))))) ;### range + ts = 0? + (let ((ts-in-pixels (round (* (- y3 y1) (/ ts (max 1 (+ range ts))))))) ; handle range + ts = 0 (setf ts-in-pixels (min (- y3 y1) ;thumb can't be larger than the thumb bed (max +minimum-thumb-size-in-pixels+ ;but shouldn't be smaller than this. ts-in-pixels)))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 18 Feb '08

18 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26794/Drei Modified Files: drei-redisplay.lisp Log Message: Fix :to-line-end keyword parameter for invalidate-strokes-in-region. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/17 14:54:47 1.67 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/18 12:22:47 1.68 @@ -344,11 +344,10 @@ :cleared cleared) ;; Only part of the line is within the region. else do (do-displayed-line-strokes (stroke line) - (when (if to-line-end - (<= start-offset (stroke-start-offset stroke)) - (overlaps start-offset end-offset - (stroke-start-offset stroke) - (stroke-end-offset stroke))) + (when (overlaps start-offset + (if to-line-end (line-end-offset line) end-offset) + (stroke-start-offset stroke) + (stroke-end-offset stroke)) (invalidate-stroke stroke :modified modified :cleared cleared))) if (= line1-index line2-index) do (loop-finish)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 18 Feb '08

18 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv4903/Drei Modified Files: lisp-syntax-swine.lisp Log Message: Added support for undefing command and undefiners. n metacircular uninterpreter! --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/16 22:06:09 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/18 10:45:26 1.18 @@ -956,6 +956,26 @@ `undefiner'. If it isn't, the results are undefined. `Syntax' is the Lisp syntax object that has `definition-form'.")) +(defvar *undefiners* (make-hash-table) + "A hash table mapping operators to undefiners. The undefiners +are instances of `undefiner'.") + +(defun get-undefiner (definition-type) + "Return the undefiner for `definition-type', which must be a +symbol. Returns NIL if there is no undefiner of the given type." + (values (gethash definition-type *undefiners*))) + +(defun invalid-form-for-type (syntax form type-name) + "Signal a `form-conversion-error' describing the fact that +`form' cannot define a `type-name'." + (form-conversion-error syntax form "Form cannot define a ~A." type-name)) + +(defun invalid-form (undefiner syntax form) + "Signal a `form-conversion-error' describing the fact that +`form' cannot define whatever kind of definition `undefiner' +handles." + (invalid-form-for-type syntax form (undefiner-type undefiner))) + (defclass simple-undefiner (undefiner) ((%undefiner-type :reader undefiner-type :initform (error "A description must be provided.") @@ -972,7 +992,7 @@ :initarg :undefiner-function))) (defmethod definition-name ((undefiner simple-undefiner) (syntax lisp-syntax) (form form)) - (form-conversion-error syntax form "Form ~A cannot define a ~A." (undefiner-type undefiner))) + (invalid-form undefiner syntax form)) (defmethod definition-name ((undefiner simple-undefiner) (syntax lisp-syntax) (form list-form)) (if (>= (length (form-children form)) 2) @@ -984,15 +1004,6 @@ (definition-name undefiner syntax form) form)) -(defvar *undefiners* (make-hash-table) - "A hash table mapping operators to undefiners. The undefiners -are instances of `undefiner'.") - -(defun get-undefiner (definition-type) - "Return the undefiner for `definition-type', which must be a -symbol. Returns NIL if there is no undefiner of the given type." - (values (gethash definition-type *undefiners*))) - (defmacro define-simple-undefiner (definition-spec (syntax-sym name-sym form-sym) &body body) "Define a way to undefine some definition. `Definition-spec' is the operator (like `defun', `defclass', etc), and `syntax-sym', @@ -1014,6 +1025,82 @@ (declare (ignorable ,syntax-sym ,name-sym ,form-sym)) ,@body))))) +(defclass generic-undefiner (undefiner) + ((%undefiner-type :reader undefiner-type + :initform (error "A description must be provided.") + :type string + :documentation "A textual, user-oriented name +for the type of definition handled by this +undefiner." + :initarg :undefiner-type) + (%name-function :reader name-function + :initform (error "A name retrieval function must be provided.") + :documentation "A function of three arguments: +the syntax object and the form to retrieve a name from. Should +return the name as a Lisp object (probably a symbol). Should +signal a `form-conversion-error' if the form cannot define +whatever type this undefiner handles." + :initarg :name-function) + (%undefiner-function :reader undefiner-function + :initform (error "An undefiner function must be provided.") + :documentation "A function of three +arguments: the syntax object, the name of the definition to be +undefined and the form to be undefined." + :initarg :undefiner-function))) + +(defmethod definition-name ((undefiner generic-undefiner) (syntax lisp-syntax) (form form)) + (funcall (name-function undefiner) syntax form)) + +(defmethod undefine ((undefiner generic-undefiner) (syntax lisp-syntax) (form form)) + (funcall (undefiner-function undefiner) syntax + (definition-name undefiner syntax form) + form)) + +(defmacro define-undefiner (definition-spec + ((name-syntax-sym name-form-sym) &body name-body) + ((undef-syntax-sym undef-name-sym undef-form-sym) + &body undefiner-body)) + "Define a way to undefine definitions. `Definition-spec' is the +operator (like `defun', `defclass', etc) and may optionally be a +list, in which case the first element is the operator, and the +second a user-oriented name for the kind of thing defined by the +operator. `Name-body' and `Undefiner-body' will be evaluated to +retrieve the name and perform the undefinition, respectively. + +`Name-syntax-sym' and `name-form-sym' will be bound to the Lisp +syntax instance and the entire form of the definition during +evaluation of `name-body'. Syntactical problems (such as an +incomplete or invalid form) should be signalled by an +invocation `(invalid)' + +`undef-syntax-sym', `undef-name-sym' and `undef-form-sym' will be +bound to the Lisp syntax instance, the name of the definition to +be undefined and the entire form of the definition when +`undefiner-body' is evaluated. Syntactical problems (such as an +incomplete or invalid form) should be signalled by an +invocation `(invalid)'." + (check-type definition-spec (or list symbol)) + (let* ((definition-type (unlisted definition-spec)) + (undefiner-name (if (listp definition-spec) + (second definition-spec) + (string-downcase definition-type)))) + (check-type definition-type symbol) + `(setf (gethash ',definition-type *undefiners*) + (make-instance 'generic-undefiner + :undefiner-type ,undefiner-name + :name-function #'(lambda (,name-syntax-sym ,name-form-sym) + (declare (ignorable ,name-syntax-sym ,name-form-sym)) + (flet ((invalid () + (invalid-form-for-type ,name-syntax-sym ,name-form-sym ,undefiner-name))) + (declare (ignorable #'invalid)) + ,@name-body)) + :undefiner-function #'(lambda (,undef-syntax-sym ,undef-name-sym ,undef-form-sym) + (declare (ignorable ,undef-syntax-sym ,undef-name-sym ,undef-form-sym)) + (flet ((invalid () + (invalid-form-for-type ,undef-syntax-sym ,undef-form-sym ,undef-name-sym))) + (declare (ignorable #'invalid)) + ,@undefiner-body)))))) + (define-simple-undefiner (defun "function") (syntax name form) (fmakunbound name)) @@ -1065,3 +1152,50 @@ (define-simple-undefiner (defpackage "package") (syntax name form) (delete-package name)) + +(defun get-listed-name (syntax form) + "Retrieve the name of `form' under the assumption that the name +is the second element of `form', and if this is a list, the first +element of that list. The secondary value will be true if a name +can be found, false otherwise." + (if (and (form-list-p form) + (>= (length (form-children form)) 2)) + (let ((name-form (second (form-children form)))) + (cond ((and (form-list-p name-form) + (form-children name-form)) + (values (form-to-object syntax (first (form-children name-form))) t)) + ((form-token-p name-form) + (values (form-to-object syntax name-form) t)) + (t (values nil nil)))) + (values nil nil))) + +;; Cannot recognize the common define-FOO-command macros. +(define-undefiner (define-command "command") + ((syntax form) + (multiple-value-bind (name success) (get-listed-name syntax form) + (if success name (invalid)))) + ((syntax name form) + ;; Pick out the command table from the define-command form. The + ;; command may also be in other command tables, but we can't find + ;; those. + (let ((name-form (listed (form-to-object syntax (second (form-children form)))))) + (destructuring-bind (ignore &key command-table keystroke &allow-other-keys) name-form + (declare (ignore ignore)) + (when command-table + (remove-command-from-command-table name command-table :errorp nil) + (remove-keystroke-from-command-table command-table keystroke :errorp nil)))) + (fmakunbound name))) + +(define-undefiner (define-undefiner "undefiner") + ((syntax form) + (multiple-value-bind (name success) (get-listed-name syntax form) + (if success name (invalid)))) + ((syntax name form) + (remhash name *undefiners*))) + +(define-undefiner (define-simple-undefiner "simple undefiner") + ((syntax form) + (multiple-value-bind (name success) (get-listed-name syntax form) + (if success name (invalid)))) + ((syntax name form) + (remhash name *undefiners*)))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 17 Feb '08

17 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23932/Drei Modified Files: drei-redisplay.lisp lr-syntax.lisp views.lisp Log Message: Fixed obscure Lisp syntax redisplay issue that could cause trouble with literal objects. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/16 10:30:10 1.66 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/17 14:54:47 1.67 @@ -442,8 +442,7 @@ (unless (stroke-modified stroke) (incf (stroke-start-offset stroke) line-change) (incf (stroke-end-offset stroke) line-change) - (when (or (null (stroke-start-offset stroke)) - (/= (stroke-start-offset stroke) offset)) + (when (/= (stroke-start-offset stroke) offset) (invalidate-stroke stroke :modified t))) (prog1 (stroke-pump view stroke pump-state) (incf (line-stroke-count line)) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/02/11 22:50:05 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/02/17 14:54:47 1.19 @@ -559,6 +559,9 @@ (line-end-offset (end-offset line))) (flet ((finish (new-offset symbol &optional stroke-drawing-options sticky-p) (setf start-symbol symbol) + (loop until (> (frame-end-offset (first drawing-options)) + new-offset) + do (pop drawing-options)) (unless (null stroke-drawing-options) (push (if (frame-sticky-p (first drawing-options)) (make-drawing-options-frame --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/16 10:30:10 1.41 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/17 14:54:47 1.42 @@ -1088,7 +1088,8 @@ for (start . end) in invalid-regions do (as-region (start end) (when (overlaps start end top-offset bot-offset) - (invalidate-strokes-in-region view start end :modified t))))) + (invalidate-strokes-in-region view start end + :modified t :to-line-end t))))) (defmethod display-drei-view-contents :around (stream (view textual-drei-syntax-view)) (let ((invalid-regions (invalidate-strokes view (syntax view))))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 16 Feb '08

16 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13651/Drei Modified Files: lisp-syntax-commands.lisp lisp-syntax-swine.lisp Log Message: Added Remove Definition command to Lisp syntax. Bound to C-c C-u. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2008/02/08 18:05:51 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2008/02/16 22:06:09 1.18 @@ -169,6 +169,37 @@ (define-command (com-eval-defun :name t :command-table pane-lisp-table) () (eval-defun (point) (current-syntax))) +(define-command (com-remove-definition :name t :command-table lisp-table) + () + "Remove the definition point is in. + +The operator of the definition form will be used to determine +what kind of definition it is. The user will be asked for +confirmation before anything is actually done." + (let ((definition-form (definition-at-mark (current-syntax) (point)))) + (if (or (null definition-form) + (mark> (point) (end-offset definition-form)) + (mark< (point) (start-offset definition-form))) + (display-message "No definition found at point.") + (handler-case + (let* ((definition-type (form-to-object (current-syntax) + (form-operator definition-form))) + (undefiner (get-undefiner definition-type))) + (if (null undefiner) + (display-message "Doesn't know how to undefine ~S." definition-type) + (handler-case + (when (accept 'boolean + :prompt (format nil "Undefine the ~A ~S?" + (undefiner-type undefiner) + (definition-name undefiner (current-syntax) definition-form)) + :default t :insert-default t) + (undefine undefiner (current-syntax) definition-form)) + (form-conversion-error (e) + (display-message "Could not undefine ~S form: ~A" definition-type (problem e)))))) + (form-conversion-error (e) + (display-message "Couldn't turn \"~A\" into valid operator: ~A" + (form-string (current-syntax) (form e)) (problem e))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Gesture bindings @@ -261,3 +292,6 @@ 'lisp-table '((#\Delete :control :meta))) +(set-key 'com-remove-definition + 'lisp-table + '((#\c :control) (#\u :control))) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/05 21:51:29 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/16 22:06:09 1.17 @@ -927,3 +927,141 @@ (result (apply #'format nil "~{{~:[No values~;~:*~{~S~^,~}~]}~}" values))) (esa:display-message result))))) + +(defclass undefiner () + () + (:documentation "A base class for classes that contain logic +for undefining Lisp constructs. Subclasses of `undefiner' must +implement the undefiner protocol. An instance of `undefiner' +works on a specific kind of definition (a `defun', `defclass', +`defgeneric', etc).")) + +(defgeneric undefiner-type (undefiner) + (:documentation "Return the kind of definition undefined by +`undefiner'. The return value is a string - a textual, +user-oriented description.")) + +(defgeneric definition-name (undefiner syntax definition-form) + (:documentation "Return the name of the definition described by +`definition-form', as per the kind of definition `undefiner' +handles. `Syntax' is the Lisp syntax object that has +`definition-form'. The name returned is an actual Lisp +object. `Form-conversion-error' is signalled if the form +describing the name cannot be converted to an object, or if the +form is otherwise inappropriate.")) + +(defgeneric undefine (undefiner syntax definition-form) + (:documentation "Undefine whatever `definition-form' defines, +provided `definition-form' is the kind of definition handled by +`undefiner'. If it isn't, the results are undefined. `Syntax' is +the Lisp syntax object that has `definition-form'.")) + +(defclass simple-undefiner (undefiner) + ((%undefiner-type :reader undefiner-type + :initform (error "A description must be provided.") + :type string + :documentation "A textual, user-oriented name +for the type of definition handled by this +undefiner." + :initarg :undefiner-type) + (%undefiner-function :reader undefiner-function + :initform (error "An undefiner function must be provided.") + :documentation "A function of three +arguments: the syntax object, the name of the definition to be +undefined and the form to be undefined." + :initarg :undefiner-function))) + +(defmethod definition-name ((undefiner simple-undefiner) (syntax lisp-syntax) (form form)) + (form-conversion-error syntax form "Form ~A cannot define a ~A." (undefiner-type undefiner))) + +(defmethod definition-name ((undefiner simple-undefiner) (syntax lisp-syntax) (form list-form)) + (if (>= (length (form-children form)) 2) + (form-to-object syntax (second-form (children form))) + (call-next-method))) + +(defmethod undefine ((undefiner simple-undefiner) (syntax lisp-syntax) (form form)) + (funcall (undefiner-function undefiner) syntax + (definition-name undefiner syntax form) + form)) + +(defvar *undefiners* (make-hash-table) + "A hash table mapping operators to undefiners. The undefiners +are instances of `undefiner'.") + +(defun get-undefiner (definition-type) + "Return the undefiner for `definition-type', which must be a +symbol. Returns NIL if there is no undefiner of the given type." + (values (gethash definition-type *undefiners*))) + +(defmacro define-simple-undefiner (definition-spec (syntax-sym name-sym form-sym) &body body) + "Define a way to undefine some definition. `Definition-spec' is +the operator (like `defun', `defclass', etc), and `syntax-sym', +`name-sym' and `form-sym' will be bound to the Lisp syntax +instance, the name of the definition to be undefined and the +entire form of the definition, when the undefinition is invoked +by the user. Syntactical problems (such as an incomplete or +invalid `form') should be signalled via `form-conversion-error'." + (check-type definition-spec (or list symbol)) + (let* ((definition-type (unlisted definition-spec)) + (undefiner-name (if (listp definition-spec) + (second definition-spec) + (string-downcase definition-type)))) + (check-type definition-type symbol) + `(setf (gethash ',definition-type *undefiners*) + (make-instance 'simple-undefiner + :undefiner-type ,undefiner-name + :undefiner-function #'(lambda (,syntax-sym ,name-sym ,form-sym) + (declare (ignorable ,syntax-sym ,name-sym ,form-sym)) + ,@body))))) + +(define-simple-undefiner (defun "function") (syntax name form) + (fmakunbound name)) + +(define-simple-undefiner (defgeneric "generic function") (syntax name form) + (fmakunbound name)) + +(define-simple-undefiner (defmacro "macro") (syntax name form) + (fmakunbound name)) + +(define-simple-undefiner (cl:defclass "class") (syntax name form) + (setf (find-class name nil) nil)) + +(define-simple-undefiner (clim-lisp:defclass "class") (syntax name form) + (setf (find-class name nil) nil)) + +(define-simple-undefiner (defmethod "method") (syntax name form) + (let ((function (fdefinition name))) + (labels ((get-qualifiers (maybe-qualifiers) + (unless (or (null maybe-qualifiers) + (form-list-p (first maybe-qualifiers))) + (cons (form-to-object syntax (first maybe-qualifiers)) + (get-qualifiers (rest maybe-qualifiers))))) + (get-specializers (maybe-specializers) + (cond ((null maybe-specializers) + (form-conversion-error syntax form "~A form invalid." 'defmethod)) + ;; Map across the elements in the lambda list. + ((form-list-p (first maybe-specializers)) + (mapcar #'(lambda (ll-form) + (if (and (form-list-p ll-form) + (second-form (children ll-form))) + (form-to-object syntax (second-form (children ll-form))) + t)) + (form-children (first maybe-specializers)))) + ;; Skip the qualifiers to get the lambda-list. + (t (get-specializers (rest maybe-specializers)))))) + (remove-method function (find-method function + (get-qualifiers (cddr (form-children form))) + (get-specializers (cddr (form-children form))) + nil))))) + +(define-simple-undefiner (defvar "special variable") (syntax name form) + (makunbound name)) + +(define-simple-undefiner (defparameter "special variable") (syntax name form) + (makunbound name)) + +(define-simple-undefiner (defconstant "constant") (syntax name form) + (makunbound name)) + +(define-simple-undefiner (defpackage "package") (syntax name form) + (delete-package name))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 16 Feb '08

16 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6197/Drei Modified Files: drei-clim.lisp Log Message: Patch from Thomas Persson to make Drei gadgets inherit the command table of their application frame. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/02/02 19:03:26 1.41 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/02/16 21:33:40 1.42 @@ -337,7 +337,8 @@ (defmethod additional-command-tables append ((drei drei-gadget-pane) (table drei-command-table)) - `(exclusive-gadget-table)) + `(exclusive-gadget-table + ,(frame-command-table *application-frame*))) (defclass drei-area (drei displayed-output-record region command-processor

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 16 Feb '08

16 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8962/Drei Modified Files: drei-redisplay.lisp views.lisp Log Message: Fixed somewhat-rare Drei redisplay issue where strokes that were changed weren't invalidated. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/15 13:16:17 1.65 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/16 10:30:10 1.66 @@ -318,14 +318,16 @@ ,@body))))) (defun invalidate-strokes-in-region (view start-offset end-offset - &key modified cleared) + &key modified cleared to-line-end) "Invalidate all the strokes of `view' that overlap the region `start-offset'/`end-offset' by setting their dirty-bit to true. If `modified' or `cleared' is true, also set their modified-bit to true. If `cleared' is true, inform the strokes that their previous output has been cleared by someone, and that they do not need to clear it themselves during their next -redisplay." +redisplay. If `to-line-end' is true, if a line is in the region, +strokes in it will be invalidated until the end, even if line-end +is beyond the region." (as-region (start-offset end-offset) ;; If the region is outside the visible region, no-op. (when (and (plusp (displayed-lines-count view)) ; If there is any display... @@ -342,9 +344,11 @@ :cleared cleared) ;; Only part of the line is within the region. else do (do-displayed-line-strokes (stroke line) - (when (overlaps start-offset end-offset - (stroke-start-offset stroke) - (stroke-end-offset stroke)) + (when (if to-line-end + (<= start-offset (stroke-start-offset stroke)) + (overlaps start-offset end-offset + (stroke-start-offset stroke) + (stroke-end-offset stroke))) (invalidate-stroke stroke :modified modified :cleared cleared))) if (= line1-index line2-index) do (loop-finish) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/15 13:17:54 1.40 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/16 10:30:10 1.41 @@ -782,7 +782,6 @@ (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) - (declare (optimize (debug 3))) (destructuring-bind (start-offset . end-offset) changed-region (with-accessors ((prefix-size lines-prefix-size) (suffix-size lines-suffix-size) @@ -808,7 +807,8 @@ (if newline-change (max start-offset (offset (bot view))) end-offset) - :modified t) + :modified t + :to-line-end t) (setf prefix-size (min start-offset prefix-size) suffix-size (min (- (size buffer) end-offset) suffix-size) buffer-size (size buffer))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 15 Feb '08

15 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6346/Drei Modified Files: views.lisp Log Message: Fixed range check on access to the flexichain of lines. Oops. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/15 13:16:17 1.39 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/15 13:17:54 1.40 @@ -797,7 +797,7 @@ return t) ;; If the line is joined with the one before or ;; after it, a newline object has been removed. - (or (when (/= line-index (nb-elements (lines view))) + (or (when (< (1+ line-index) (nb-elements (lines view))) (= (start-offset (element* (lines view) (1+ line-index))) (end-offset line))) (when (plusp line-index)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 15 Feb '08

15 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6104/Drei Modified Files: drei-redisplay.lisp lisp-syntax.lisp packages.lisp syntax.lisp views.lisp Log Message: Improved Drei redisplay performance by 66% in most cases. The main difference is that syntaxes are now supposed to report which parts of the display may need to be updated, previously their view of the display was computed for every redisplay iteration, and any changes drawn. Of course, no syntaxes do that yet, so if you use Lisp block-comments or string-quoting, you will see "delayed" redrawing of some parts of the display. Just like Emacs! Currently, a heuristic is used that invalidates parts of the display corresponding to buffer regions that have actually been changed, so it does work fine for the common cases. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/13 21:58:50 1.64 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/15 13:16:17 1.65 @@ -427,24 +427,21 @@ some point)." (aref (line-strokes line) (1- (line-stroke-count line)))) -(defun put-stroke (view line pump-state line-change) +(defun put-stroke (view line pump-state line-change offset) "Use `stroke-pump' with `pump-state' to get a new stroke for `view', and add it to the sequence of displayed strokes in `line'. `Line-change' should be a relative offset specifying how much the start-offset of `line' has changed since the last time it was redisplayed. `Offset' is the offset at which the next stroke will start." - (let* ((stroke (line-stroke-information line (line-stroke-count line))) - (old-start-offset (stroke-start-offset stroke)) - (old-end-offset (stroke-end-offset stroke)) - (old-drawing-options (stroke-drawing-options stroke))) + (let ((stroke (line-stroke-information line (line-stroke-count line)))) + (unless (stroke-modified stroke) + (incf (stroke-start-offset stroke) line-change) + (incf (stroke-end-offset stroke) line-change) + (when (or (null (stroke-start-offset stroke)) + (/= (stroke-start-offset stroke) offset)) + (invalidate-stroke stroke :modified t))) (prog1 (stroke-pump view stroke pump-state) - (unless (and old-start-offset - (= (+ old-start-offset line-change) (stroke-start-offset stroke)) - (= (+ old-end-offset line-change) (stroke-end-offset stroke)) - (drawing-options-equal old-drawing-options - (stroke-drawing-options stroke))) - (invalidate-stroke stroke :modified t)) (incf (line-stroke-count line)) (setf (line-end-offset line) (stroke-end-offset stroke))))) @@ -685,8 +682,8 @@ for index from 0 for stroke = (line-stroke-information line index) for stroke-dimensions = (stroke-dimensions stroke) - for pump-state = (put-stroke view line initial-pump-state offset-change) - then (put-stroke view line pump-state offset-change) + for pump-state = (put-stroke view line initial-pump-state offset-change offset) + then (put-stroke view line pump-state offset-change offset) do (update-stroke-dimensions pane view stroke cursor-x cursor-y) (setf cursor-x (x2 stroke-dimensions)) (setf offset (stroke-end-offset stroke)) @@ -795,7 +792,8 @@ (pane-height (bounding-rectangle-height (or (pane-viewport pane) pane)))) ;; For invalidation of the parts of the display that have ;; changed. - (synchronize-view view :begin (offset (top view)) :end (offset (bot view))) + (synchronize-view view :begin (offset (top view)) :end (max (offset (bot view)) + (offset (top view)))) (setf (displayed-lines-count view) 0 (max-line-width view) 0) (multiple-value-bind (cursor-x cursor-y) (stream-cursor-position pane) @@ -890,6 +888,35 @@ (defmethod stroke-pump ((view drei-buffer-view) stroke pump-state) (buffer-view-stroke-pump view stroke pump-state)) +;;; The following is the equivalent of a turbocharger for the +;;; redisplay engine. +(defstruct (skipalong-pump-state + (:constructor make-skipalong-pump-state (offset))) + "A pump state for fast skipalong that doesn't involve +the (potentially expensive) actual stroke pump. It transparently +turns into a real pump state when it happens across invalid +strokes. `Offset' is the offset of the next stroke to be pumped." + offset) + +(defmethod stroke-pump :around ((view drei-buffer-view) (stroke displayed-stroke) + (pump-state skipalong-pump-state)) + (with-accessors ((state-offset skipalong-pump-state-offset)) pump-state + (if (or (stroke-modified stroke) + (/= (stroke-start-offset stroke) state-offset)) + (stroke-pump view stroke (pump-state-for-offset view state-offset)) + (progn (setf state-offset + (+ (stroke-end-offset stroke) + (if (offset-end-of-line-p + (buffer view) (stroke-end-offset stroke)) + 1 0))) + pump-state)))) + +(defmethod stroke-pump :around ((view drei-buffer-view) (stroke displayed-stroke) + pump-state) + (if (stroke-modified stroke) + (call-next-method) + (stroke-pump view stroke (make-skipalong-pump-state (stroke-start-offset stroke))))) + ;;; Cursor handling. (defun offset-in-stroke-position (stream view stroke offset) @@ -1170,7 +1197,7 @@ (setf (offset top) (offset bot)) (beginning-of-line top) (setf (offset (point view)) (offset top)) - (invalidate-all-strokes view)))) + (invalidate-all-strokes view :modified t)))) (defmethod page-up (pane (view drei-buffer-view)) (with-accessors ((top top) (bot bot)) view --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/02/10 00:42:03 1.74 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/02/15 13:16:17 1.75 @@ -1921,6 +1921,24 @@ (defmethod syntax-highlighting-rules ((syntax lisp-syntax)) *syntax-highlighting-rules*) +(defmethod invalidate-strokes ((view textual-drei-syntax-view) (syntax lisp-syntax)) + ;; Invalidate the area touched by parenthesis highlighting, if + ;; applicable. Cheap test to do coarse elimination... + (when (or (and (not (end-of-buffer-p (point view))) + (equal (object-after (point view)) #$)) + (and (not (beginning-of-buffer-p (point view))) + (equal (object-before (point view)) #$))) + ;; Might still be a fake match, so do the semiexpensive proper test. + (let ((form (form-around syntax (offset (point view))))) + (when form + (let ((start-offset (start-offset form)) + (end-offset (end-offset form))) + (when (or (mark= start-offset (point view)) + (mark= end-offset (point view))) + ;; We actually have parenthesis highlighting. + (list (cons start-offset (1+ start-offset)) + (cons (1- end-offset) end-offset)))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; exploit the parse --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/11 23:05:22 1.52 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/15 13:16:17 1.53 @@ -220,7 +220,7 @@ #:drei-buffer-view #:buffer #:top #:bot #:buffer-view-p #:lines - #:buffer-line #:start-mark #:line-length #:chunks #:end-offset + #:buffer-line #:start-mark #:end-mark #:line-length #:chunks #:line-containing-offset #:offset-in-line-p #:buffer-view-pump-state-for-offset #:buffer-view-stroke-pump @@ -243,6 +243,8 @@ #:overwrite-mode #:goal-column + #:invalidate-strokes + #:view-command-tables #:use-editor-commands-p #:synchronize-view @@ -538,6 +540,8 @@ #:action #:new-state #:done #:reduce-fixed-number #:reduce-until-type #:reduce-all #:error-state #:error-reduce-state + #:do-parse-symbols-forward + #:parser-symbol-containing-offset #:define-syntax-highlighting-rules #:syntax-highlighting-rules) (:documentation "Underlying LR parsing functionality.")) --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/02/08 18:37:32 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/02/15 13:16:17 1.19 @@ -22,7 +22,7 @@ (in-package :drei-syntax) -(defclass syntax (name-mixin) +(defclass syntax (name-mixin observable-mixin) ((%buffer :initarg :buffer :reader buffer) (%command-table :initarg :command-table :initform (error "A command table has not been provided for this syntax") --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/14 08:15:01 1.38 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/15 13:16:17 1.39 @@ -605,7 +605,10 @@ (%lines-suffix :accessor lines-suffix-size :documentation "The number of unchanged objects at the end of the buffer since since the list of lines was last -updated.")) +updated.") + (%last-seen-buffer-size :accessor last-seen-buffer-size + :documentation "The buffer size the +last time a change to the buffer was registered.")) (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' object. The buffer is displayed on a simple line-by-line basis, @@ -618,7 +621,8 @@ (declare (ignore initargs)) (with-accessors ((top top) (bot bot) (lines-prefix lines-prefix-size) - (lines-suffix lines-suffix-size)) view + (lines-suffix lines-suffix-size) + (buffer-size last-seen-buffer-size)) view (unless buffer ;; So many fun things are defined on (setf buffer) that we use ;; slot-value here. This is just a glorified initform anyway. @@ -629,7 +633,8 @@ (setf top (make-buffer-mark (buffer view) 0 :left) bot (clone-mark top :right) lines-prefix 0 - lines-suffix 0))) + lines-suffix 0 + buffer-size (size (buffer view))))) (defmethod (setf top) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view)) @@ -641,11 +646,13 @@ (invalidate-all-strokes view) (with-accessors ((top top) (bot bot) (lines-prefix lines-prefix-size) - (lines-suffix lines-suffix-size)) view + (lines-suffix lines-suffix-size) + (buffer-size last-seen-buffer-size)) view (setf top (make-buffer-mark buffer 0 :left) bot (clone-mark top :right) lines-prefix 0 - lines-suffix 0))) + lines-suffix 0 + buffer-size 0))) (defmethod cache-string :around ((view drei-buffer-view)) (let ((string (call-next-method))) @@ -670,9 +677,9 @@ ((%start-mark :reader start-mark :initarg :start-mark :documentation "The mark at which this line starts.") - (%line-length :reader line-length - :initarg :line-length - :documentation "The length of the line described by this object.") + (%end-mark :reader end-mark + :initarg :end-mark + :documentation "The mark at which this line ends.") (%chunks :accessor chunks :initform (make-array 5 :adjustable t @@ -700,9 +707,15 @@ when (= chunk-start-offset line-end-offset) do (loop-finish))) +(defmethod start-offset ((line buffer-line)) + (offset (start-mark line))) + (defmethod end-offset ((line buffer-line)) - "Return the end buffer offset of `line'." - (+ (offset (start-mark line)) (line-length line))) + (offset (end-mark line))) + +(defun line-length (line) + "Return the length of the `buffer-line' object `line'." + (- (end-offset line) (start-offset line))) (defun get-chunk (buffer line-start-offset chunk-start-offset line-end-offset) "Return a chunk in the form of a cons cell. The chunk will @@ -755,12 +768,11 @@ ;; Analyze new lines. (loop while (mark<= low-mark high-mark) for i from low-index - do (progn (let ((line-start-mark (clone-mark low-mark))) - (insert* lines i (make-instance - 'buffer-line + do (progn (let ((line-start-mark (clone-mark low-mark :left)) + (line-end-mark (clone-mark (end-of-line low-mark) :right))) + (insert* lines i (make-instance 'buffer-line :start-mark line-start-mark - :line-length (- (offset (end-of-line low-mark)) - (offset line-start-mark)))) + :end-mark line-end-mark)) (if (end-of-buffer-p low-mark) (loop-finish) ;; skip newline @@ -770,12 +782,40 @@ (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) + (declare (optimize (debug 3))) (destructuring-bind (start-offset . end-offset) changed-region - (invalidate-strokes-in-region view start-offset end-offset :modified t) (with-accessors ((prefix-size lines-prefix-size) - (suffix-size lines-suffix-size)) view - (setf prefix-size (min start-offset prefix-size) - suffix-size (min (- (size buffer) end-offset) suffix-size))))) + (suffix-size lines-suffix-size) + (buffer-size last-seen-buffer-size)) view + ;; Figure out whether the change involved insertion or deletion of + ;; a newline. + (let* ((line-index (index-of-line-containing-offset view start-offset)) + (line (element* (lines view) line-index)) + (newline-change + (or (loop for index from start-offset below end-offset + when (equal (buffer-object (buffer view) index) #\Newline) + return t) + ;; If the line is joined with the one before or + ;; after it, a newline object has been removed. + (or (when (/= line-index (nb-elements (lines view))) + (= (start-offset (element* (lines view) (1+ line-index))) + (end-offset line))) + (when (plusp line-index) + (= (end-offset (element* (lines view) (1- line-index))) + (start-offset line))))))) + ;; If the line structure changed, everything after the newline is suspect. + (invalidate-strokes-in-region view start-offset + (if newline-change + (max start-offset (offset (bot view))) + end-offset) + :modified t) + (setf prefix-size (min start-offset prefix-size) + suffix-size (min (- (size buffer) end-offset) suffix-size) + buffer-size (size buffer)) + ;; If the line structure changed, we need to update the line + ;; data, or we can't pick up future changes correctly. + (when newline-change + (update-line-data view)))))) (defmethod synchronize-view ((view drei-buffer-view) &key) (update-line-data view)) @@ -844,13 +884,14 @@ &key (syntax *default-syntax*)) (declare (ignore args)) (check-type syntax (or symbol syntax)) - (with-accessors ((view-syntax syntax) - (buffer buffer) + (with-accessors ((buffer buffer) (suffix-size suffix-size) (prefix-size prefix-size)) view - (setf view-syntax (if (symbolp syntax) - (make-syntax-for-view view syntax) - syntax)) + (setf (slot-value view '%syntax) + (if (symbolp syntax) + (make-syntax-for-view view syntax) + syntax)) + (add-observer (syntax view) view) (add-observer buffer view))) (defmethod (setf buffer) :before ((buffer drei-buffer) (view drei-syntax-view)) @@ -866,7 +907,11 @@ (with-accessors ((view-syntax syntax)) view (setf view-syntax (make-syntax-for-view view (class-of view-syntax))))) +(defmethod (setf syntax) :before (syntax (view drei-syntax-view)) + (remove-observer (syntax view) view)) + (defmethod (setf syntax) :after (syntax (view drei-syntax-view)) + (add-observer syntax view) (setf (prefix-size view) 0 (suffix-size view) 0 (buffer-size view) -1)) @@ -899,6 +944,11 @@ modified-p t))) (call-next-method)) +(defmethod observer-notified ((view drei-syntax-view) (syntax syntax) + changed-region) + (destructuring-bind (start-offset . end-offset) changed-region + (invalidate-strokes-in-region view start-offset end-offset :modified t))) + (defun needs-resynchronization (view) "Return true if the the view of the buffer of `view' is potentially out of date. Return false otherwise." @@ -1018,6 +1068,37 @@ highlighting, and maintains point and mark marks into the buffer, in order to permit useful editing commands.")) +(defgeneric invalidate-strokes (view syntax) + (:documentation "Called just before redisplay of the +`textual-drei-syntax-view' `view' in order to give `syntax', +which is the syntax of `view', a chance to mark part of the +display as invalid due to do something not caused by buffer +modification (for example, parenthesis matching). This function +should return a list of pairs of buffer offsets, each pair +delimiting a buffer region that should be redrawn.") + (:method ((view textual-drei-syntax-view view) (syntax syntax)) + nil)) + +(defun invalidate-as-appropriate (view invalid-regions) + "Invalidate strokes of `view' overlapping regions in +`invalid-regions'. `Invalid-regions' is a list of conses of +buffer offsets delimiting regions." + (loop with top-offset = (offset (top view)) + with bot-offset = (offset (bot view)) + for (start . end) in invalid-regions + do (as-region (start end) + (when (overlaps start end top-offset bot-offset) + (invalidate-strokes-in-region view start end :modified t))))) + +(defmethod display-drei-view-contents :around (stream (view textual-drei-syntax-view)) + (let ((invalid-regions (invalidate-strokes view (syntax view)))) + (invalidate-as-appropriate view invalid-regions) + (call-next-method) + ;; We do not expect whatever ephemeral state that caused + ;; invalidation to stick around until the next redisplay, so + ;; whatever it imposed on us, mark as dirty immediately. + (invalidate-as-appropriate view invalid-regions))) + (defmethod create-view-cursors nconc ((output-stream extended-output-stream) (view textual-drei-syntax-view)) (unless (no-cursors view)

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by rschlatte 15 Feb '08

15 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv8522/Apps/Listener Modified Files: README TODO listener.lisp Log Message: Use clim-user as default package in new listener. Document current prompting behaviour in README --- /project/mcclim/cvsroot/mcclim/Apps/Listener/README 2005/05/12 01:37:20 1.5 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/README 2008/02/15 09:48:37 1.6 @@ -49,13 +49,10 @@ Usage ----- -After starting the listener, a typical lisp prompt will be displayed, with -the package name preceding the prompt. You may type lisp forms or commands to -this prompt. The listener will treat alphabetical characters as beginning a -command name, and most other characters as the beginning of a lisp form. If for -some reason you had a special variable with a name such as FOO which would be -interpreted as a command, you can use a comma before the variable name as an -escape character. +After starting the listener, a typical lisp prompt will be displayed, with the +package name preceding the prompt. You may type lisp forms or commands to this +prompt. The , (comma) character starts a command, every other input will be +treated by the listener as a form to be evaluated. At the bottom of the window is a wholine which shows various things such as the username/hostname, package, current directory (*default-pathname-defaults*), --- /project/mcclim/cvsroot/mcclim/Apps/Listener/TODO 2005/05/12 01:37:20 1.2 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/TODO 2008/02/15 09:48:41 1.3 @@ -14,7 +14,6 @@ to distinguish between subtypes in methods. - Flesh out icons - support multiple sizes in separate subdirectories of icons/ - Implement sorting and other options to Show Directory - - Do something about Edit File and Show File - Copy File, Delete File, etc. - Debugger integration --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/02/03 19:07:51 1.42 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/02/15 09:48:41 1.43 @@ -71,6 +71,7 @@ (defmethod stream-present :around ((stream listener-interactor-pane) object type &rest args &key (single-box nil sbp) &allow-other-keys) + (declare (ignore single-box sbp)) (apply #'call-next-method stream object type :single-box t args) ;; we would do this, but CLIM:PRESENT calls STREAM-PRESENT with all ;; the keyword arguments explicitly. *sigh*. @@ -166,15 +167,17 @@ (height 550) port frame-manager - (process-name "Listener")) + (process-name "Listener") + (package :clim-user)) (let* ((fm (or frame-manager (find-frame-manager :port (or port (find-port))))) (frame (make-application-frame 'listener :frame-manager fm :width width :height height))) (flet ((run () - (unwind-protect (run-frame-top-level frame) - (disown-frame fm frame)))) + (let ((*package* (find-package package))) + (unwind-protect (run-frame-top-level frame) + (disown-frame fm frame))))) (if new-process (values (clim-sys:make-process #'run :name process-name) frame)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 14 Feb '08

14 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31883/Drei Modified Files: views.lisp Log Message: Oops, accidentally reintroduced old bug. Pick up on buffer changes affecting strokes. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/13 21:58:50 1.37 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/14 08:15:01 1.38 @@ -771,6 +771,7 @@ (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) (destructuring-bind (start-offset . end-offset) changed-region + (invalidate-strokes-in-region view start-offset end-offset :modified t) (with-accessors ((prefix-size lines-prefix-size) (suffix-size lines-suffix-size)) view (setf prefix-size (min start-offset prefix-size)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 13 Feb '08

13 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15222/Drei Modified Files: drei-redisplay.lisp views.lisp Log Message: Some general cleanups in Drei redisplay. No functionality changes. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/12 19:22:37 1.63 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/13 21:58:50 1.64 @@ -272,37 +272,6 @@ do (invalidate-line-strokes line :modified modified :cleared cleared))) -(defun invalidate-strokes-in-region (view start-offset end-offset - &key modified cleared) - "Invalidate all the strokes of `view' that overlap the region -`start-offset'/`end-offset' by setting their dirty-bit to -true. If `modified' or `cleared' is true, also set their -modified-bit to true. If `cleared' is true, inform the strokes -that their previous output has been cleared by someone, and that -they do not need to clear it themselves during their next -redisplay." - ;; If the region is outside the visible region, no-op. - (when (overlaps start-offset end-offset - (offset (top view)) (offset (bot view))) - (let ((line1-index (index-of-displayed-line-containing-offset view start-offset)) - (line2-index (index-of-displayed-line-containing-offset view end-offset))) - (loop for line = (line-information view line1-index) - when (<= start-offset - (line-start-offset line) (line-end-offset line) - end-offset) - ;; The entire line is within the region. - do (invalidate-line-strokes line :modified modified - :cleared cleared) - ;; Only part of the line is within the region. - else do (do-displayed-line-strokes (stroke line) - (when (overlaps start-offset end-offset - (stroke-start-offset stroke) - (stroke-end-offset stroke)) - (invalidate-stroke stroke :modified modified - :cleared cleared))) - if (= line1-index line2-index) do (loop-finish) - else do (incf line1-index))))) - (defmacro do-displayed-lines ((line-sym view) &body body) "Loop over lines on display for `view', evaluating `body' with `line-sym' bound to the `displayed-line' object for each line." @@ -348,6 +317,39 @@ (+ (line-stroke-count ,line) ,stroke-index)))) ,@body))))) +(defun invalidate-strokes-in-region (view start-offset end-offset + &key modified cleared) + "Invalidate all the strokes of `view' that overlap the region +`start-offset'/`end-offset' by setting their dirty-bit to +true. If `modified' or `cleared' is true, also set their +modified-bit to true. If `cleared' is true, inform the strokes +that their previous output has been cleared by someone, and that +they do not need to clear it themselves during their next +redisplay." + (as-region (start-offset end-offset) + ;; If the region is outside the visible region, no-op. + (when (and (plusp (displayed-lines-count view)) ; If there is any display... + (overlaps start-offset end-offset + (offset (top view)) (offset (bot view)))) + (let ((line1-index (index-of-displayed-line-containing-offset view start-offset)) + (line2-index (index-of-displayed-line-containing-offset view end-offset))) + (loop for line = (line-information view line1-index) + when (<= start-offset + (line-start-offset line) (line-end-offset line) + end-offset) + ;; The entire line is within the region. + do (invalidate-line-strokes line :modified modified + :cleared cleared) + ;; Only part of the line is within the region. + else do (do-displayed-line-strokes (stroke line) + (when (overlaps start-offset end-offset + (stroke-start-offset stroke) + (stroke-end-offset stroke)) + (invalidate-stroke stroke :modified modified + :cleared cleared))) + if (= line1-index line2-index) do (loop-finish) + else do (incf line1-index)))))) + (defun find-stroke-containing-offset (view offset) "Find the stroke of `view' that displays the buffer offset `offset'. If no such stroke can be found, this function returns @@ -430,7 +432,8 @@ `view', and add it to the sequence of displayed strokes in `line'. `Line-change' should be a relative offset specifying how much the start-offset of `line' has changed since the last time -it was redisplayed." +it was redisplayed. `Offset' is the offset at which the next +stroke will start." (let* ((stroke (line-stroke-information line (line-stroke-count line))) (old-start-offset (stroke-start-offset stroke)) (old-end-offset (stroke-end-offset stroke)) @@ -678,19 +681,21 @@ ;; ugly, just complex. (multiple-value-bind (line-width baseline descent pump-state) ;; Pump all the line strokes and calculate their dimensions. - (loop for index from 0 - for stroke = (line-stroke-information line index) - for stroke-dimensions = (stroke-dimensions stroke) - for pump-state = (put-stroke view line initial-pump-state offset-change) then - (put-stroke view line pump-state offset-change) - do (update-stroke-dimensions pane view stroke cursor-x cursor-y) - (setf cursor-x (x2 stroke-dimensions)) - maximizing (- (dimensions-height stroke-dimensions) - (center stroke-dimensions)) into descent - maximizing (+ (center stroke-dimensions) cursor-y) into baseline - summing (dimensions-width stroke-dimensions) into line-width - when (stroke-at-end-of-line (buffer view) stroke) - return (values line-width baseline descent pump-state)) + (loop with offset = start-offset + for index from 0 + for stroke = (line-stroke-information line index) + for stroke-dimensions = (stroke-dimensions stroke) + for pump-state = (put-stroke view line initial-pump-state offset-change) + then (put-stroke view line pump-state offset-change) + do (update-stroke-dimensions pane view stroke cursor-x cursor-y) + (setf cursor-x (x2 stroke-dimensions)) + (setf offset (stroke-end-offset stroke)) + maximizing (- (dimensions-height stroke-dimensions) + (center stroke-dimensions)) into descent + maximizing (+ (center stroke-dimensions) cursor-y) into baseline + summing (dimensions-width stroke-dimensions) into line-width + when (stroke-at-end-of-line (buffer view) stroke) + return (values line-width baseline descent pump-state)) (let ((line-height (- (+ baseline descent) cursor-y))) ;; Loop over the strokes and clear the parts of the pane that ;; has to be redrawn, trying to minimise the number of calls to @@ -783,16 +788,19 @@ (defmethod display-drei-view-contents ((pane basic-pane) (view drei-buffer-view)) (with-bounding-rectangle* (x1 y1 x2 y2) view - (let ((old-width (- x2 x1)) - (old-height (- y2 y1))) + (let* ((old-width (- x2 x1)) + (old-height (- y2 y1)) + (start-offset (offset (beginning-of-line (top view)))) + (pump-state (pump-state-for-offset view start-offset)) + (pane-height (bounding-rectangle-height (or (pane-viewport pane) pane)))) + ;; For invalidation of the parts of the display that have + ;; changed. + (synchronize-view view :begin (offset (top view)) :end (offset (bot view))) (setf (displayed-lines-count view) 0 (max-line-width view) 0) (multiple-value-bind (cursor-x cursor-y) (stream-cursor-position pane) (with-output-recording-options (pane :record nil :draw t) - (loop with start-offset = (offset (beginning-of-line (top view))) - with pump-state = (pump-state-for-offset view start-offset) - with pane-height = (bounding-rectangle-height (or (pane-viewport pane) pane)) - for line = (line-information view (displayed-lines-count view)) + (loop for line = (line-information view (displayed-lines-count view)) do (multiple-value-bind (new-pump-state line-height) (draw-line-strokes pane view pump-state start-offset cursor-x cursor-y old-width) @@ -823,17 +831,19 @@ "Return a pump state usable for pumpting strokes for `view' (a `drei-buffer-view') from `offset'." ;; Perform binary search looking for line starting with `offset'. + (synchronize-view view :begin offset) (with-accessors ((lines lines)) view (loop with low-index = 0 with high-index = (nb-elements lines) for middle = (floor (+ low-index high-index) 2) - for line-start = (start-mark (element* lines middle)) - do (cond ((mark> offset line-start) + for this-line = (element* lines middle) + for line-start = (start-mark this-line) + do (cond ((offset-in-line-p this-line offset) + (loop-finish)) + ((mark> offset line-start) (setf low-index (1+ middle))) ((mark< offset line-start) - (setf high-index middle)) - ((mark= offset line-start) - (loop-finish))) + (setf high-index middle))) finally (return (make-pump-state middle offset 0))))) (defun fetch-chunk (line chunk-index) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/12 19:22:37 1.36 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/13 21:58:50 1.37 @@ -578,7 +578,7 @@ the string is accessed through the reader.") (%displayed-lines :accessor displayed-lines :initform (make-array 0 :element-type 'displayed-line - :initial-element (make-displayed-line)) + :initial-element (make-displayed-line)) :type array :documentation "An array of the `displayed-line' objects displayed by the view. Not all of these @@ -594,10 +594,18 @@ :type number :documentation "The width of the longest displayed line in device units.") - (lines :initform (make-instance 'standard-flexichain) - :reader lines - :documentation "The lines of the buffer, stored in a -format that makes it easy to retrieve information about them.")) + (%lines :initform (make-instance 'standard-flexichain) + :reader lines + :documentation "The lines of the buffer, stored in a +format that makes it easy to retrieve information about them.") + (%lines-prefix :accessor lines-prefix-size + :documentation "The number of unchanged +objects at the start of the buffer since the list of lines was +last updated.") + (%lines-suffix :accessor lines-suffix-size + :documentation "The number of unchanged objects +at the end of the buffer since since the list of lines was last +updated.")) (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' object. The buffer is displayed on a simple line-by-line basis, @@ -608,7 +616,9 @@ &key buffer single-line read-only initial-contents) (declare (ignore initargs)) - (with-accessors ((top top) (bot bot)) view + (with-accessors ((top top) (bot bot) + (lines-prefix lines-prefix-size) + (lines-suffix lines-suffix-size)) view (unless buffer ;; So many fun things are defined on (setf buffer) that we use ;; slot-value here. This is just a glorified initform anyway. @@ -617,8 +627,9 @@ :read-only read-only :initial-contents initial-contents))) (setf top (make-buffer-mark (buffer view) 0 :left) - bot (make-buffer-mark (buffer view) (size (buffer view)) :right)) - (update-line-data view 0 (size (buffer view))))) + bot (clone-mark top :right) + lines-prefix 0 + lines-suffix 0))) (defmethod (setf top) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view)) @@ -628,12 +639,13 @@ (defmethod (setf buffer) :after (buffer (view drei-buffer-view)) (invalidate-all-strokes view) - (with-accessors ((top top) (bot bot)) view - (setf top (make-buffer-mark buffer 0 :left) - bot (make-buffer-mark buffer (size buffer) :right)))) - -(defmethod (setf syntax) :after (new-value (view drei-buffer-view)) - (invalidate-all-strokes view :modified t)) + (with-accessors ((top top) (bot bot) + (lines-prefix lines-prefix-size) + (lines-suffix lines-suffix-size)) view + (setf top (make-buffer-mark buffer 0 :left) + bot (clone-mark top :right) + lines-prefix 0 + lines-suffix 0))) (defmethod cache-string :around ((view drei-buffer-view)) (let ((string (call-next-method))) @@ -713,55 +725,59 @@ (cons (- (1+ chunk-end-offset) line-start-offset) t))))) -(defun update-line-data (view start end) +(defun update-line-data (view) "Update the sequence of lines stored by the `drei-buffer-view' -`view'. `Start' and `end' are buffer offsets delimiting the -region that has changed since the last update." - (let ((low-mark (make-buffer-mark (buffer view) start :left)) - (high-mark (make-buffer-mark (buffer view) end :left))) - (when (mark<= low-mark high-mark) - (beginning-of-line low-mark) - (end-of-line high-mark) - (with-accessors ((lines lines)) view - (let ((low-index 0) - (high-index (nb-elements lines))) - ;; Binary search for the start of changed lines. - (loop while (< low-index high-index) - do (let* ((middle (floor (+ low-index high-index) 2)) - (line-start (start-mark (element* lines middle)))) - (cond ((mark> low-mark line-start) - (setf low-index (1+ middle))) - (t - (setf high-index middle))))) - ;; Discard lines that have to be re-analyzed. - (loop while (and (< low-index (nb-elements lines)) - (mark<= (start-mark (element* lines low-index)) - high-mark)) - do (delete* lines low-index)) - ;; Analyze new lines. - (loop while (mark<= low-mark high-mark) - for i from low-index - do (progn (let ((line-start-mark (clone-mark low-mark))) - (insert* lines i (make-instance - 'buffer-line - :start-mark line-start-mark - :line-length (- (offset (end-of-line low-mark)) - (offset line-start-mark)))) - (if (end-of-buffer-p low-mark) - (loop-finish) - ;; skip newline - (forward-object low-mark)))))))))) +`view'." + (with-accessors ((prefix-size lines-prefix-size) + (suffix-size lines-suffix-size)) view + (when (<= prefix-size (- (size (buffer view)) suffix-size)) + (let ((low-mark (make-buffer-mark (buffer view) prefix-size :left)) + (high-mark (make-buffer-mark + (buffer view) (- (size (buffer view)) suffix-size) :left))) + (beginning-of-line low-mark) + (end-of-line high-mark) + (with-accessors ((lines lines)) view + (let ((low-index 0) + (high-index (nb-elements lines))) + ;; Binary search for the start of changed lines. + (loop while (< low-index high-index) + do (let* ((middle (floor (+ low-index high-index) 2)) + (line-start (start-mark (element* lines middle)))) + (cond ((mark> low-mark line-start) + (setf low-index (1+ middle))) + (t + (setf high-index middle))))) + ;; Discard lines that have to be re-analyzed. + (loop while (and (< low-index (nb-elements lines)) + (mark<= (start-mark (element* lines low-index)) + high-mark)) + do (delete* lines low-index)) + ;; Analyze new lines. + (loop while (mark<= low-mark high-mark) + for i from low-index + do (progn (let ((line-start-mark (clone-mark low-mark))) + (insert* lines i (make-instance + 'buffer-line + :start-mark line-start-mark + :line-length (- (offset (end-of-line low-mark)) + (offset line-start-mark)))) + (if (end-of-buffer-p low-mark) + (loop-finish) + ;; skip newline + (forward-object low-mark))))))))) + (setf prefix-size (size (buffer view)) + suffix-size (size (buffer view))))) (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) (destructuring-bind (start-offset . end-offset) changed-region - ;; If something has been redisplayed, and there have been changes - ;; to some of those strokes, mark them as dirty. - (invalidate-strokes-in-region - view start-offset end-offset :modified t) - ;; I suspect it's most efficient to keep this always up to date, - ;; even for small changes. - (update-line-data view start-offset end-offset))) + (with-accessors ((prefix-size lines-prefix-size) + (suffix-size lines-suffix-size)) view + (setf prefix-size (min start-offset prefix-size) + suffix-size (min (- (size buffer) end-offset) suffix-size))))) + +(defmethod synchronize-view ((view drei-buffer-view) &key) + (update-line-data view)) ;;; Exploit the stored line information. @@ -771,24 +787,32 @@ (<= (offset (start-mark line)) offset (end-offset line))) +(defun index-of-line-containing-offset (view mark-or-offset) + "Return the index of the line `mark-or-offset' is in for +`view'. `View' must be a `drei-buffer-view'." + ;; Perform binary search looking for line containing `offset1'. + (as-offsets ((offset mark-or-offset)) + (with-accessors ((lines lines)) view + (loop with low-index = 0 + with high-index = (nb-elements lines) + for middle = (floor (+ low-index high-index) 2) + for this-line = (element* lines middle) + for line-start = (start-mark this-line) + do (cond ((offset-in-line-p this-line offset) + (loop-finish)) + ((mark> offset line-start) + (setf low-index (1+ middle))) + ((mark< offset line-start) + (setf high-index middle))) + finally (return middle))))) + (defun line-containing-offset (view mark-or-offset) "Return the line `mark-or-offset' is in for `view'. `View' must be a `drei-buffer-view'." ;; Perform binary search looking for line containing `offset1'. (as-offsets ((offset mark-or-offset)) (with-accessors ((lines lines)) view - (loop with low-index = 0 - with high-index = (nb-elements lines) - for middle = (floor (+ low-index high-index) 2) - for this-line = (element* lines middle) - for line-start = (start-mark this-line) - do (cond ((offset-in-line-p this-line offset) - (loop-finish)) - ((mark> offset line-start) - (setf low-index (1+ middle))) - ((mark< offset line-start) - (setf high-index middle))) - finally (return this-line))))) + (element* lines (index-of-line-containing-offset view offset))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -838,11 +862,7 @@ (add-observer buffer view) ;; We need a new syntax object of the same type as the old one, and ;; to zero out the unchanged-prefix-values. - (with-accessors ((view-syntax syntax) - (suffix-size suffix-size) - (prefix-size prefix-size) - (buffer-size buffer-size) - (bot bot) (top top)) view + (with-accessors ((view-syntax syntax)) view (setf view-syntax (make-syntax-for-view view (class-of view-syntax))))) (defmethod (setf syntax) :after (syntax (view drei-syntax-view)) @@ -869,17 +889,18 @@ (defmethod observer-notified ((view drei-syntax-view) (buffer drei-buffer) changed-region) - (with-accessors ((prefix-size prefix-size) - (suffix-size suffix-size)) view - (setf prefix-size (min (car changed-region) prefix-size) - suffix-size (min (- (size buffer) (cdr changed-region)) - suffix-size) - (modified-p view) t)) + (destructuring-bind (start-offset . end-offset) changed-region + (with-accessors ((prefix-size prefix-size) + (suffix-size suffix-size) + (modified-p modified-p)) view + (setf prefix-size (min start-offset prefix-size) + suffix-size (min (- (size buffer) end-offset) suffix-size) + modified-p t))) (call-next-method)) (defun needs-resynchronization (view) "Return true if the the view of the buffer of `view' is -potentially out of date. Return false otherwise." +potentially out of date. Return false otherwise." (not (= (prefix-size view) (suffix-size view) (buffer-size view) (size (buffer view)))))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 12 Feb '08

12 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv20991/Drei Modified Files: drei-redisplay.lisp views.lisp Log Message: Changed how buffer changes are registered by the redisplay module. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/11 23:05:21 1.62 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/12 19:22:37 1.63 @@ -272,6 +272,37 @@ do (invalidate-line-strokes line :modified modified :cleared cleared))) +(defun invalidate-strokes-in-region (view start-offset end-offset + &key modified cleared) + "Invalidate all the strokes of `view' that overlap the region +`start-offset'/`end-offset' by setting their dirty-bit to +true. If `modified' or `cleared' is true, also set their +modified-bit to true. If `cleared' is true, inform the strokes +that their previous output has been cleared by someone, and that +they do not need to clear it themselves during their next +redisplay." + ;; If the region is outside the visible region, no-op. + (when (overlaps start-offset end-offset + (offset (top view)) (offset (bot view))) + (let ((line1-index (index-of-displayed-line-containing-offset view start-offset)) + (line2-index (index-of-displayed-line-containing-offset view end-offset))) + (loop for line = (line-information view line1-index) + when (<= start-offset + (line-start-offset line) (line-end-offset line) + end-offset) + ;; The entire line is within the region. + do (invalidate-line-strokes line :modified modified + :cleared cleared) + ;; Only part of the line is within the region. + else do (do-displayed-line-strokes (stroke line) + (when (overlaps start-offset end-offset + (stroke-start-offset stroke) + (stroke-end-offset stroke)) + (invalidate-stroke stroke :modified modified + :cleared cleared))) + if (= line1-index line2-index) do (loop-finish) + else do (incf line1-index))))) + (defmacro do-displayed-lines ((line-sym view) &body body) "Loop over lines on display for `view', evaluating `body' with `line-sym' bound to the `displayed-line' object for each line." @@ -328,10 +359,11 @@ (end-offset (stroke-end-offset stroke)))) (return stroke)))))) -(defun find-index-of-line-containing-offset (view offset) - "Return the index of the line containing `offset'. If `offset' -is before the displayed lines, return 0. If `offset' is after the -displayed lines, return the index of the last line." +(defun index-of-displayed-line-containing-offset (view offset) + "Return the index of the `displayed-line' object containing +`offset'. If `offset' is before the displayed lines, return 0. If +`offset' is after the displayed lines, return the index of the +last line." (with-accessors ((lines displayed-lines)) view (cond ((< offset (line-start-offset (aref lines 0))) 0) @@ -340,18 +372,18 @@ (t ;; Binary search for the line. (loop with low-index = 0 - with high-index = (displayed-lines-count view) - for middle = (floor (+ low-index high-index) 2) - for this-line = (aref lines middle) - for line-start = (line-start-offset this-line) - for line-end = (line-end-offset this-line) - do (cond ((<= line-start offset line-end) - (loop-finish)) - ((mark> offset line-start) - (setf low-index (1+ middle))) - ((mark< offset line-start) - (setf high-index middle))) - finally (return middle)))))) + with high-index = (displayed-lines-count view) + for middle = (floor (+ low-index high-index) 2) + for this-line = (aref lines middle) + for line-start = (line-start-offset this-line) + for line-end = (line-end-offset this-line) + do (cond ((<= line-start offset line-end) + (loop-finish)) + ((> offset line-start) + (setf low-index (1+ middle))) + ((< offset line-start) + (setf high-index middle))) + finally (return middle)))))) (defun ensure-line-information-size (view min-size) "Ensure that the array of lines for `view' contains at least @@ -402,24 +434,14 @@ (let* ((stroke (line-stroke-information line (line-stroke-count line))) (old-start-offset (stroke-start-offset stroke)) (old-end-offset (stroke-end-offset stroke)) - (old-drawing-options (stroke-drawing-options stroke)) - (changed-region (first (changed-regions view)))) + (old-drawing-options (stroke-drawing-options stroke))) (prog1 (stroke-pump view stroke pump-state) (unless (and old-start-offset (= (+ old-start-offset line-change) (stroke-start-offset stroke)) (= (+ old-end-offset line-change) (stroke-end-offset stroke)) (drawing-options-equal old-drawing-options - (stroke-drawing-options stroke)) - (or (null changed-region) - (not (overlaps (stroke-start-offset stroke) (stroke-end-offset stroke) - (car changed-region) (cdr changed-region))))) + (stroke-drawing-options stroke))) (invalidate-stroke stroke :modified t)) - ;; Move to the next changed region, if it is not possible for - ;; more stroks to overlap with the current one. - (loop while (and (first (changed-regions view)) - (>= (stroke-end-offset stroke) - (cdr (first (changed-regions view))))) - do (pop (changed-regions view))) (incf (line-stroke-count line)) (setf (line-end-offset line) (stroke-end-offset stroke))))) @@ -634,7 +656,8 @@ (do-undisplayed-line-strokes (stroke line) (if (null (stroke-start-offset stroke)) (return) - (setf (stroke-start-offset stroke) nil)))) + (progn (setf (stroke-start-offset stroke) nil) + (invalidate-stroke stroke :modified t))))) (defun draw-line-strokes (pane view initial-pump-state start-offset cursor-x cursor-y @@ -711,7 +734,8 @@ (do-undisplayed-line-strokes (stroke line) (if (null (stroke-start-offset stroke)) (return) - (setf (stroke-start-offset stroke) nil)))) + (progn (setf (stroke-start-offset stroke) nil) + (invalidate-stroke stroke :modified t))))) (with-bounding-rectangle* (x1 y1 x2 y2) view (declare (ignore x2)) (when (> old-height (- y2 y1)) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/11 22:50:05 1.35 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/12 19:22:37 1.36 @@ -594,12 +594,6 @@ :type number :documentation "The width of the longest displayed line in device units.") - (%changed-regions :accessor changed-regions - :initform nil - :documentation "A list of (start . end) conses -of buffer offsets, delimiting the regions of the buffer that have -changed since the last redisplay. The regions are not -overlapping, and are sorted in ascending order.") (lines :initform (make-instance 'standard-flexichain) :reader lines :documentation "The lines of the buffer, stored in a @@ -632,8 +626,11 @@ (defmethod (setf bot) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view)) -(defmethod (setf buffer) :after (new-value (view drei-buffer-view)) - (invalidate-all-strokes view)) +(defmethod (setf buffer) :after (buffer (view drei-buffer-view)) + (invalidate-all-strokes view) + (with-accessors ((top top) (bot bot)) view + (setf top (make-buffer-mark buffer 0 :left) + bot (make-buffer-mark buffer (size buffer) :right)))) (defmethod (setf syntax) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view :modified t)) @@ -657,32 +654,6 @@ (<= y1 x1 x2 y2) (<= x1 y1 y1 x2))) -(defun remember-changed-region (view start end) - "Note that the buffer region delimited by the offset `start' -and `end' has been modified." - (labels ((worker (list) - ;; Return a new changed-regions list. Try to extend old - ;; regions instead of adding new ones. - (cond ((null list) - (list (cons start end))) - ;; If start/end overlaps with (first list), extend - ;; (first list) - ((overlaps start end (car (first list)) (cdr (first list))) - (setf (car (first list)) (min start (car (first list))) - (cdr (first list)) (max end (cdr (first list)))) - list) - ;; If start/end is wholly before (first list), push - ;; on a new region. - ((< start (car (first list))) - (cons (cons start end) list)) - ;; If start/end is wholly before (first list), go - ;; further down list. If at end of list, add new - ;; element. - ((< (cdr (first list)) end) - (setf (rest list) (worker (rest list))) - list)))) - (setf (changed-regions view) (worker (changed-regions view))))) - (defclass buffer-line () ((%start-mark :reader start-mark :initarg :start-mark @@ -783,12 +754,14 @@ (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) - ;; If something has been redisplayed, and there have been changes to - ;; some of those lines, mark them as dirty. - (remember-changed-region view (car changed-region) (cdr changed-region)) - ;; I suspect it's most efficient to keep this always up to date, - ;; even for small changes. - (update-line-data view (car changed-region) (cdr changed-region))) + (destructuring-bind (start-offset . end-offset) changed-region + ;; If something has been redisplayed, and there have been changes + ;; to some of those strokes, mark them as dirty. + (invalidate-strokes-in-region + view start-offset end-offset :modified t) + ;; I suspect it's most efficient to keep this always up to date, + ;; even for small changes. + (update-line-data view start-offset end-offset))) ;;; Exploit the stored line information. @@ -866,21 +839,11 @@ ;; We need a new syntax object of the same type as the old one, and ;; to zero out the unchanged-prefix-values. (with-accessors ((view-syntax syntax) - (point point) (mark mark) (suffix-size suffix-size) (prefix-size prefix-size) (buffer-size buffer-size) (bot bot) (top top)) view - (setf point (clone-mark (point buffer)) - mark (clone-mark (point buffer) :right) - (offset mark) 0 - view-syntax (make-syntax-for-view view (class-of view-syntax)) - prefix-size 0 - suffix-size 0 - buffer-size -1 ; For reparse even if buffer is empty. - ;; Also set the top and bot marks. - top (make-buffer-mark buffer 0 :left) - bot (make-buffer-mark buffer (size buffer) :right)))) + (setf view-syntax (make-syntax-for-view view (class-of view-syntax))))) (defmethod (setf syntax) :after (syntax (view drei-syntax-view)) (setf (prefix-size view) 0

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 11 Feb '08

11 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27656/Drei Modified Files: drei-redisplay.lisp fundamental-syntax.lisp packages.lisp Log Message: Replace the old and inefficient generic buffer view redisplay with new one based on functionality stolen from Fundamental syntax. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/03 19:17:26 1.61 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/11 23:05:21 1.62 @@ -757,48 +757,6 @@ (+ width cursor-x) cursor-y draw baseline))))))) -(defmethod pump-state-for-offset ((view drei-buffer-view) (offset integer)) - "For a `drei-buffer-view' a pump-state is merely an offset into -the buffer determining where the next stroke should start." - offset) - -(defun fetch-chunk (buffer chunk-start-offset) - "Retrieve a chunk from `buffer', with the chunk starting at -`chunk-start-offset'. The chunk is a cons, with the car being the -start-offset of the chunk as an integer, and the cdr being either -the end-offset of the chunk as an integer, or a function. If a -function, the chunk is a one-object non-string chunk, and the -function is the drawing function for the chunk." - (let* ((line-end-offset (end-of-line-offset - buffer chunk-start-offset)) - (chunk-end-offset (buffer-find-nonchar - buffer chunk-start-offset - (min (+ *maximum-chunk-size* - chunk-start-offset) - line-end-offset)))) - (cond ((or (not (= chunk-end-offset chunk-start-offset)) - (and (offset-beginning-of-line-p buffer chunk-start-offset) - (offset-end-of-line-p buffer chunk-end-offset))) - (cons chunk-start-offset - chunk-end-offset)) - ((not (characterp (buffer-object buffer chunk-end-offset))) - (cons chunk-end-offset (object-drawer)))))) - -(defmethod stroke-pump ((view drei-buffer-view) stroke pump-state) - (let* ((chunk (fetch-chunk (buffer view) pump-state)) - (drawing-options (if (functionp (cdr chunk)) - (make-drawing-options :function (cdr chunk)) - +default-drawing-options+)) - (actual-end-offset (if (functionp (cdr chunk)) - (1+ (car chunk)) - (cdr chunk)))) - (setf (stroke-start-offset stroke) (car chunk) - (stroke-end-offset stroke) actual-end-offset - (stroke-drawing-options stroke) drawing-options) - (if (offset-end-of-line-p (buffer view) actual-end-offset) - (1+ actual-end-offset) - actual-end-offset))) - (defmethod display-drei-view-contents ((pane basic-pane) (view drei-buffer-view)) (with-bounding-rectangle* (x1 y1 x2 y2) view (let ((old-width (- x2 x1)) @@ -824,6 +782,82 @@ (setf (offset (bot view)) (line-end-offset line)) (clear-stale-lines pane view old-width old-height)))))))) +;;; A default redisplay implementation that should work for subclasses +;;; of `drei-buffer-view'. Syntaxes that don't want to implement their +;;; own redisplay behavior can just call these. + +(defstruct (pump-state + (:constructor make-pump-state + (line-index offset chunk-index))) + "A pump state object used by the `drei-buffer-view'. `Line' is +the line object `offset' is in, and `line-index' is the index of +`line' in the list of lines maintained by the view that created +this pump state." + line-index offset chunk-index) + +(defun buffer-view-pump-state-for-offset (view offset) + "Return a pump state usable for pumpting strokes for `view' (a +`drei-buffer-view') from `offset'." + ;; Perform binary search looking for line starting with `offset'. + (with-accessors ((lines lines)) view + (loop with low-index = 0 + with high-index = (nb-elements lines) + for middle = (floor (+ low-index high-index) 2) + for line-start = (start-mark (element* lines middle)) + do (cond ((mark> offset line-start) + (setf low-index (1+ middle))) + ((mark< offset line-start) + (setf high-index middle)) + ((mark= offset line-start) + (loop-finish))) + finally (return (make-pump-state middle offset 0))))) + +(defun fetch-chunk (line chunk-index) + "Retrieve the `chunk-index'th chunk from `line'. The return +value is either an integer, in which case it specifies the +end-offset of a string chunk relative to the start of the line, +or a function, in which case it is the drawing function for a +single-object non-character chunk." + (destructuring-bind (relative-chunk-end-offset . objectp) + (aref (chunks line) chunk-index) + (if objectp (object-drawer) (+ relative-chunk-end-offset + (offset (start-mark line)))))) + +(defun buffer-view-stroke-pump (view stroke pump-state) + "Pump redisplay data into `stroke' based on `pump-state' and +the information managed by `view', which must be a +`drei-buffer-view'." + ;; `Pump-state' will be destructively modified. + (prog1 pump-state + (with-accessors ((line-index pump-state-line-index) + (offset pump-state-offset) + (chunk-index pump-state-chunk-index)) pump-state + (let* ((chunk (fetch-chunk + (element* (lines view) line-index) chunk-index)) + (drawing-options (if (functionp chunk) + (make-drawing-options :function chunk) + +default-drawing-options+)) + (end-offset (if (functionp chunk) + (1+ offset) + chunk))) + (setf (stroke-start-offset stroke) offset + (stroke-end-offset stroke) end-offset + (stroke-drawing-options stroke) drawing-options) + (if (offset-end-of-line-p (buffer view) end-offset) + (setf line-index (1+ line-index) + chunk-index 0 + offset (1+ end-offset)) + (setf chunk-index (1+ chunk-index) + offset end-offset)))))) + +(defmethod pump-state-for-offset ((view drei-buffer-view) (offset integer)) + (buffer-view-pump-state-for-offset view offset)) + +(defmethod stroke-pump ((view drei-buffer-view) stroke pump-state) + (buffer-view-stroke-pump view stroke pump-state)) + +;;; Cursor handling. + (defun offset-in-stroke-position (stream view stroke offset) "Calculate the position in device units of `offset' in `stroke', relative to the starting position of `stroke'. `Offset' --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/02/11 22:50:04 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/02/11 23:05:22 1.13 @@ -53,71 +53,18 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; display - -(defstruct (pump-state - (:constructor make-pump-state - (line-index offset chunk-index))) - "A pump state object used in the fundamental syntax. `Line' is -the line object `offset' is in, and `line-index' is the index of -`line' in the list of lines maintained by the syntax that created -this pump state." - line-index - offset - chunk-index) +;;; Redisplay +;;; +;;; Just uses the default buffer-view redisplay behavior. (defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) (syntax fundamental-syntax) (offset integer)) - ;; Perform binary search looking for line starting with `offset'. - (with-accessors ((lines lines)) view - (loop with low-index = 0 - with high-index = (nb-elements lines) - for middle = (floor (+ low-index high-index) 2) - for line-start = (start-mark (element* lines middle)) - do (cond ((mark> offset line-start) - (setf low-index (1+ middle))) - ((mark< offset line-start) - (setf high-index middle)) - ((mark= offset line-start) - (loop-finish))) - finally (return (make-pump-state middle offset 0))))) - -(defun fetch-chunk (line chunk-index) - "Retrieve the `chunk-index'th chunk from `line'. The return -value is either an integer, in which case it specifies the -end-offset of a string chunk relative to the start of the line, -or a function, in which case it is the drawing function for a -single-object non-character chunk." - (destructuring-bind (relative-chunk-end-offset . objectp) - (aref (chunks line) chunk-index) - (if objectp (object-drawer) (+ relative-chunk-end-offset - (offset (start-mark line)))))) + (buffer-view-pump-state-for-offset view offset)) (defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) (syntax fundamental-syntax) stroke - (pump-state pump-state)) - ;; `Pump-state' will be destructively modified. - (prog1 pump-state - (with-accessors ((line-index pump-state-line-index) - (offset pump-state-offset) - (chunk-index pump-state-chunk-index)) pump-state - (let* ((chunk (fetch-chunk - (element* (lines view) line-index) chunk-index)) - (drawing-options (if (functionp chunk) - (make-drawing-options :function chunk) - +default-drawing-options+)) - (end-offset (if (functionp chunk) - (1+ offset) - chunk))) - (setf (stroke-start-offset stroke) offset - (stroke-end-offset stroke) end-offset - (stroke-drawing-options stroke) drawing-options) - (if (offset-end-of-line-p (buffer view) end-offset) - (setf line-index (1+ line-index) - chunk-index 0 - offset (1+ end-offset)) - (setf chunk-index (1+ chunk-index) - offset end-offset)))))) + pump-state) + (buffer-view-stroke-pump view stroke pump-state)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/11 22:50:05 1.51 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/11 23:05:22 1.52 @@ -222,6 +222,8 @@ #:lines #:buffer-line #:start-mark #:line-length #:chunks #:end-offset #:line-containing-offset #:offset-in-line-p + #:buffer-view-pump-state-for-offset + #:buffer-view-stroke-pump #:drei-syntax-view #:syntax #:syntax-view-p #:pump-state-for-offset-with-syntax

1 0

[mcclim-cvs] CVS mcclim/Apps/Inspector
by thenriksen 11 Feb '08

11 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv23316/Apps/Inspector Modified Files: inspector.lisp Log Message: Once again accidentally committed local debugging hack... --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/02/11 22:50:04 1.43 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/02/11 22:51:42 1.44 @@ -47,7 +47,7 @@ :display-function 'display-app) (int :interactor :width 600 :height 100 :max-height 100)) (:layouts - (default (vertically () (scrolling () app) #+nil int)))) + (default (vertically () (scrolling () app) int)))) (defmethod initialize-instance :after ((frame inspector) &rest args) (declare (ignore args))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 11 Feb '08

11 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23082/Drei Modified Files: fundamental-syntax.lisp lr-syntax.lisp packages.lisp views.lisp Log Message: Flayed Fundamental syntax, most of what it used to do is now done by the drei-buffer-view directly. --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/07 22:01:53 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/02/11 22:50:04 1.12 @@ -34,119 +34,22 @@ ;;; The syntax object and misc stuff. (define-syntax fundamental-syntax (syntax) - ((lines :initform (make-instance 'standard-flexichain) - :reader lines) - (scan :accessor scan)) + () (:command-table fundamental-table) (:name "Fundamental")) -(defmethod initialize-instance :after ((syntax fundamental-syntax) &rest args) - (declare (ignore args)) - (with-accessors ((buffer buffer) (scan scan)) syntax - (setf scan (make-buffer-mark buffer 0 :left)))) - (setf *default-syntax* 'fundamental-syntax) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; update syntax -(defclass line-object () - ((%start-mark :reader start-mark - :initarg :start-mark) - (%line-length :reader line-length - :initarg :line-length) - (%chunks :accessor chunks - :initform (make-array 5 - :adjustable t - :fill-pointer 0) - :documentation "A list of cons-cells, with the car -being a buffer offset relative to the `start-mark' of the line, -and the cdr being T if the chunk covers a non-character, and NIL -if it covers a character sequence."))) - -(defun line-end-offset (line) - "Return the end buffer offset of `line'." - (+ (offset (start-mark line)) (line-length line))) - -(defun get-chunk (buffer line-start-offset chunk-start-offset line-end-offset) - "Return a chunk in the form of a cons cell. The chunk will -start at `chunk-start-offset' and extend no further than -`line-end-offset'." - (let* ((chunk-end-offset (buffer-find-nonchar - buffer chunk-start-offset - (min (+ *maximum-chunk-size* - chunk-start-offset) - line-end-offset)))) - (cond ((= chunk-start-offset line-end-offset) - (cons (- chunk-end-offset - line-start-offset) nil)) - ((or (not (= chunk-end-offset chunk-start-offset)) - (and (offset-beginning-of-line-p buffer chunk-start-offset) - (offset-end-of-line-p buffer chunk-end-offset))) - (cons (- chunk-end-offset - line-start-offset) nil)) - ((not (characterp (buffer-object buffer chunk-end-offset))) - (cons (- (1+ chunk-end-offset) - line-start-offset) t))))) - (defmethod update-syntax values-max-min ((syntax fundamental-syntax) prefix-size suffix-size &optional begin end) (declare (ignore begin end)) - (let ((low-mark (make-buffer-mark (buffer syntax) prefix-size :left)) - (high-mark (make-buffer-mark - (buffer syntax) (- (size (buffer syntax)) suffix-size) :left))) - (when (mark<= low-mark high-mark) - (beginning-of-line low-mark) - (end-of-line high-mark) - (with-slots (lines scan) syntax - (let ((low-index 0) - (high-index (nb-elements lines))) - ;; Binary search for the start of changed lines. - (loop while (< low-index high-index) - do (let* ((middle (floor (+ low-index high-index) 2)) - (line-start (start-mark (element* lines middle)))) - (cond ((mark> low-mark line-start) - (setf low-index (1+ middle))) - (t - (setf high-index middle))))) - ;; Discard lines that have to be re-analyzed. - (loop while (and (< low-index (nb-elements lines)) - (mark<= (start-mark (element* lines low-index)) - high-mark)) - do (delete* lines low-index)) - ;; Analyze new lines. - (setf (offset scan) (offset low-mark)) - (loop while (mark<= scan high-mark) - for i from low-index - do (progn (let ((line-start-mark (clone-mark scan))) - (insert* lines i (make-instance - 'line-object - :start-mark line-start-mark - :line-length (- (offset (end-of-line scan)) - (offset line-start-mark)))) - (if (end-of-buffer-p scan) - (loop-finish) - ;; skip newline - (forward-object scan)))))))) - ;; Fundamental syntax always parses the entire buffer. - (values 0 (size (buffer syntax))))) - -(defmethod initialize-instance :after ((line line-object) - &rest initargs) - (declare (ignore initargs)) - (loop with buffer = (buffer (start-mark line)) - with line-start-offset = (offset (start-mark line)) - with line-end-offset = (+ line-start-offset (line-length line)) - with chunk-start-offset = line-start-offset - for chunk-info = (get-chunk buffer - line-start-offset - chunk-start-offset line-end-offset) - do (vector-push-extend chunk-info (chunks line)) - (setf chunk-start-offset (+ (car chunk-info) - line-start-offset)) - when (= chunk-start-offset line-end-offset) - do (loop-finish))) + ;; We do nothing. Technically, Fundamental syntax always parses the + ;; entire buffer, though. + (values 0 (size (buffer syntax)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -165,20 +68,19 @@ (defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) (syntax fundamental-syntax) (offset integer)) - (update-parse syntax 0 offset) ;; Perform binary search looking for line starting with `offset'. - (with-accessors ((lines lines)) syntax + (with-accessors ((lines lines)) view (loop with low-index = 0 - with high-index = (nb-elements lines) - for middle = (floor (+ low-index high-index) 2) - for line-start = (start-mark (element* lines middle)) - do (cond ((mark> offset line-start) - (setf low-index (1+ middle))) - ((mark< offset line-start) - (setf high-index middle)) - ((mark= offset line-start) - (loop-finish))) - finally (return (make-pump-state middle offset 0))))) + with high-index = (nb-elements lines) + for middle = (floor (+ low-index high-index) 2) + for line-start = (start-mark (element* lines middle)) + do (cond ((mark> offset line-start) + (setf low-index (1+ middle))) + ((mark< offset line-start) + (setf high-index middle)) + ((mark= offset line-start) + (loop-finish))) + finally (return (make-pump-state middle offset 0))))) (defun fetch-chunk (line chunk-index) "Retrieve the `chunk-index'th chunk from `line'. The return @@ -199,9 +101,8 @@ (with-accessors ((line-index pump-state-line-index) (offset pump-state-offset) (chunk-index pump-state-chunk-index)) pump-state - (update-parse syntax 0 offset) (let* ((chunk (fetch-chunk - (element* (lines syntax) line-index) chunk-index)) + (element* (lines view) line-index) chunk-index)) (drawing-options (if (functionp chunk) (make-drawing-options :function chunk) +default-drawing-options+)) @@ -222,31 +123,6 @@ ;;; ;;; exploit the parse -(defun offset-in-line-p (line offset) - "Return true if `offset' is in the buffer region delimited by -`line'." - (<= (offset (start-mark line)) offset - (line-end-offset line))) - -(defun line-containing-offset (syntax mark-or-offset) - "Return the line `mark-or-offset' is in for `syntax'. `Syntax' -must be a `fundamental-syntax' object." - ;; Perform binary search looking for line containing `offset1'. - (as-offsets ((offset mark-or-offset)) - (with-accessors ((lines lines)) syntax - (loop with low-index = 0 - with high-index = (nb-elements lines) - for middle = (floor (+ low-index high-index) 2) - for this-line = (element* lines middle) - for line-start = (start-mark this-line) - do (cond ((offset-in-line-p this-line offset) - (loop-finish)) - ((mark> offset line-start) - (setf low-index (1+ middle))) - ((mark< offset line-start) - (setf high-index middle))) - finally (return this-line))))) - ;; do this better (defmethod syntax-line-indentation ((syntax fundamental-syntax) mark tab-width) 0) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/02/10 00:42:03 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/02/11 22:50:05 1.18 @@ -35,7 +35,8 @@ (current-state) (initial-state :initarg :initial-state) (current-start-mark) - (current-size))) + (current-size) + (scan :accessor scan))) (defmethod initialize-instance :after ((syntax lr-syntax-mixin) &rest args) (declare (ignore args)) @@ -554,7 +555,8 @@ (drawing-options pump-state-drawing-options) (highlighting-rules pump-state-highlighting-rules)) pump-state - (let ((line (line-containing-offset (syntax view) offset))) + (let* ((line (line-containing-offset view offset)) + (line-end-offset (end-offset line))) (flet ((finish (new-offset symbol &optional stroke-drawing-options sticky-p) (setf start-symbol symbol) (unless (null stroke-drawing-options) @@ -567,7 +569,7 @@ (return-from find-next-stroke-end new-offset))) (cond ((null start-symbol) ;; This means that all remaining lines are blank. - (finish (line-end-offset line) nil)) + (finish line-end-offset nil)) ((and (typep start-symbol 'literal-object-mixin) (= offset (start-offset start-symbol))) (finish (end-offset start-symbol) start-symbol nil)) @@ -584,8 +586,8 @@ (let ((options-to-be-used (if (frame-sticky-p (first drawing-options)) (frame-drawing-options (first drawing-options)) symbol-drawing-options))) - (cond ((> (start-offset symbol) (line-end-offset line)) - (finish (line-end-offset line) start-symbol)) + (cond ((> (start-offset symbol) line-end-offset) + (finish line-end-offset start-symbol)) ((and (typep symbol 'literal-object-mixin)) (finish (start-offset symbol) symbol (or symbol-drawing-options @@ -607,7 +609,7 @@ ;; If there are no more parse symbols, we just go ;; line-by-line from here. This should mean that all ;; remaining lines are blank. - (finish (line-end-offset line) nil)))))))) + (finish line-end-offset nil)))))))) (defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) (syntax lr-syntax-mixin) stroke --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/31 12:14:05 1.50 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/11 22:50:05 1.51 @@ -217,11 +217,18 @@ ;; Views and their facilities. #:drei-view #:modified-p #:no-cursors + #:drei-buffer-view #:buffer #:top #:bot #:buffer-view-p + #:lines + #:buffer-line #:start-mark #:line-length #:chunks #:end-offset + #:line-containing-offset #:offset-in-line-p + #:drei-syntax-view #:syntax #:syntax-view-p #:pump-state-for-offset-with-syntax #:stroke-pump-with-syntax + #:point-mark-view #:point-mark-view-p + #:textual-drei-syntax-view #:tab-space-count #:space-width #:tab-width #:use-tabs #:auto-fill-mode #:auto-fill-column @@ -509,9 +516,7 @@ (defpackage :drei-fundamental-syntax (:use :clim-lisp :clim :drei-buffer :drei-base :drei-syntax :flexichain :drei :drei-core :esa-utils) - (:export #:fundamental-syntax #:scan - #:start-mark #:line-length #:line-end-offset - #:line-containing-offset #:offset-in-line-p) + (:export #:fundamental-syntax) (:documentation "Implementation of the basic syntax module for editing plain text.")) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/03 07:16:48 1.34 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/11 22:50:05 1.35 @@ -550,6 +550,10 @@ (:documentation "Scroll `view', which is displayed on `pane', a page up.")) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Buffer view + (defclass drei-buffer-view (drei-view) ((%buffer :accessor buffer :initarg :buffer @@ -595,7 +599,11 @@ :documentation "A list of (start . end) conses of buffer offsets, delimiting the regions of the buffer that have changed since the last redisplay. The regions are not -overlapping, and are sorted in ascending order.")) +overlapping, and are sorted in ascending order.") + (lines :initform (make-instance 'standard-flexichain) + :reader lines + :documentation "The lines of the buffer, stored in a +format that makes it easy to retrieve information about them.")) (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' object. The buffer is displayed on a simple line-by-line basis, @@ -615,7 +623,8 @@ :read-only read-only :initial-contents initial-contents))) (setf top (make-buffer-mark (buffer view) 0 :left) - bot (make-buffer-mark (buffer view) (size (buffer view)) :right)))) + bot (make-buffer-mark (buffer view) (size (buffer view)) :right)) + (update-line-data view 0 (size (buffer view))))) (defmethod (setf top) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view)) @@ -674,11 +683,143 @@ list)))) (setf (changed-regions view) (worker (changed-regions view))))) +(defclass buffer-line () + ((%start-mark :reader start-mark + :initarg :start-mark + :documentation "The mark at which this line starts.") + (%line-length :reader line-length + :initarg :line-length + :documentation "The length of the line described by this object.") + (%chunks :accessor chunks + :initform (make-array 5 + :adjustable t + :fill-pointer 0) + :documentation "A list of cons-cells, with the car +being a buffer offset relative to the `start-mark' of the line, +and the cdr being T if the chunk covers a non-character, and NIL +if it covers a character sequence.")) + (:documentation "An object describing a single line in the +buffer associated with a `drei-buffer-view'")) + +(defmethod initialize-instance :after ((line buffer-line) + &rest initargs) + (declare (ignore initargs)) + (loop with buffer = (buffer (start-mark line)) + with line-start-offset = (offset (start-mark line)) + with line-end-offset = (+ line-start-offset (line-length line)) + with chunk-start-offset = line-start-offset + for chunk-info = (get-chunk buffer + line-start-offset + chunk-start-offset line-end-offset) + do (vector-push-extend chunk-info (chunks line)) + (setf chunk-start-offset (+ (car chunk-info) + line-start-offset)) + when (= chunk-start-offset line-end-offset) + do (loop-finish))) + +(defmethod end-offset ((line buffer-line)) + "Return the end buffer offset of `line'." + (+ (offset (start-mark line)) (line-length line))) + +(defun get-chunk (buffer line-start-offset chunk-start-offset line-end-offset) + "Return a chunk in the form of a cons cell. The chunk will +start at `chunk-start-offset' and extend no further than +`line-end-offset'." + (let* ((chunk-end-offset (buffer-find-nonchar + buffer chunk-start-offset + (min (+ *maximum-chunk-size* + chunk-start-offset) + line-end-offset)))) + (cond ((= chunk-start-offset line-end-offset) + (cons (- chunk-end-offset + line-start-offset) nil)) + ((or (not (= chunk-end-offset chunk-start-offset)) + (and (offset-beginning-of-line-p buffer chunk-start-offset) + (offset-end-of-line-p buffer chunk-end-offset))) + (cons (- chunk-end-offset + line-start-offset) nil)) + ((not (characterp (buffer-object buffer chunk-end-offset))) + (cons (- (1+ chunk-end-offset) + line-start-offset) t))))) + +(defun update-line-data (view start end) + "Update the sequence of lines stored by the `drei-buffer-view' +`view'. `Start' and `end' are buffer offsets delimiting the +region that has changed since the last update." + (let ((low-mark (make-buffer-mark (buffer view) start :left)) + (high-mark (make-buffer-mark (buffer view) end :left))) + (when (mark<= low-mark high-mark) + (beginning-of-line low-mark) + (end-of-line high-mark) + (with-accessors ((lines lines)) view + (let ((low-index 0) + (high-index (nb-elements lines))) + ;; Binary search for the start of changed lines. + (loop while (< low-index high-index) + do (let* ((middle (floor (+ low-index high-index) 2)) + (line-start (start-mark (element* lines middle)))) + (cond ((mark> low-mark line-start) + (setf low-index (1+ middle))) + (t + (setf high-index middle))))) + ;; Discard lines that have to be re-analyzed. + (loop while (and (< low-index (nb-elements lines)) + (mark<= (start-mark (element* lines low-index)) + high-mark)) + do (delete* lines low-index)) + ;; Analyze new lines. + (loop while (mark<= low-mark high-mark) + for i from low-index + do (progn (let ((line-start-mark (clone-mark low-mark))) + (insert* lines i (make-instance + 'buffer-line + :start-mark line-start-mark + :line-length (- (offset (end-of-line low-mark)) + (offset line-start-mark)))) + (if (end-of-buffer-p low-mark) + (loop-finish) + ;; skip newline + (forward-object low-mark)))))))))) + (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) ;; If something has been redisplayed, and there have been changes to ;; some of those lines, mark them as dirty. - (remember-changed-region view (car changed-region) (cdr changed-region))) + (remember-changed-region view (car changed-region) (cdr changed-region)) + ;; I suspect it's most efficient to keep this always up to date, + ;; even for small changes. + (update-line-data view (car changed-region) (cdr changed-region))) + +;;; Exploit the stored line information. + +(defun offset-in-line-p (line offset) + "Return true if `offset' is in the buffer region delimited by +`line'." + (<= (offset (start-mark line)) offset + (end-offset line))) + +(defun line-containing-offset (view mark-or-offset) + "Return the line `mark-or-offset' is in for `view'. `View' +must be a `drei-buffer-view'." + ;; Perform binary search looking for line containing `offset1'. + (as-offsets ((offset mark-or-offset)) + (with-accessors ((lines lines)) view + (loop with low-index = 0 + with high-index = (nb-elements lines) + for middle = (floor (+ low-index high-index) 2) + for this-line = (element* lines middle) + for line-start = (start-mark this-line) + do (cond ((offset-in-line-p this-line offset) + (loop-finish)) + ((mark> offset line-start) + (setf low-index (1+ middle))) + ((mark< offset line-start) + (setf high-index middle))) + finally (return this-line))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Syntax views (defclass drei-syntax-view (drei-buffer-view) ((%syntax :accessor syntax

1 0

[mcclim-cvs] CVS mcclim/Apps/Inspector
by thenriksen 11 Feb '08

11 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv23082/Apps/Inspector Modified Files: inspector.lisp Log Message: Flayed Fundamental syntax, most of what it used to do is now done by the drei-buffer-view directly. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/02/03 23:42:01 1.42 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/02/11 22:50:04 1.43 @@ -47,7 +47,7 @@ :display-function 'display-app) (int :interactor :width 600 :height 100 :max-height 100)) (:layouts - (default (vertically () (scrolling () app) int)))) + (default (vertically () (scrolling () app) #+nil int)))) (defmethod initialize-instance :after ((frame inspector) &rest args) (declare (ignore args))

1 0

[mcclim-cvs] CVS mcclim-website
by thenriksen 11 Feb '08

11 Feb '08

Update of /project/mcclim/cvsroot/mcclim-website In directory clnet:/tmp/cvs-serv18182 Modified Files: index.html Log Message: Some more Google-optimisation. --- /project/mcclim/cvsroot/mcclim-website/index.html 2008/02/05 13:00:32 1.4 +++ /project/mcclim/cvsroot/mcclim-website/index.html 2008/02/11 19:26:32 1.5 @@ -1,15 +1,20 @@ <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"> <html> <head> - <title>McCLIM</title> + <title>McCLIM - A powerful GUI toolkit for Common Lisp</title> <link rel="stylesheet" type="text/css" href="mcclim.css"> + <meta name="keywords" content="Common Lisp, Lisp, CLIM, McCLIM, + GUI" /> + <meta name="description" content="The project page for an +implementation of CLIM, a GUI toolkit written in, and for, Common +Lisp." /> </head> <body> <br> <center> <img src="McCLIM-3.png"> - <h1>Welcome</h1> + <h1>A GUI toolkit for Common Lisp</h1> </center> <div class="link-sidebar"> @@ -140,7 +145,7 @@ </div> <br> <hr> -$Date: 2008/02/05 13:00:32 $ +$Date: 2008/02/11 19:26:32 $

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 10 Feb '08

10 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv32363/Drei Modified Files: lisp-syntax.lisp lr-syntax.lisp Log Message: Added notion of "sticky" highlighting rules to LR syntax. Used this to add syntax highlighting for reader conditionals in Lisp syntax. Has instant gratification - faster than SLIME! (Ok, we cheat, and can just look at the running Lisp, but anyway.) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/31 18:44:36 1.73 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/02/10 00:42:03 1.74 @@ -994,7 +994,8 @@ ;;;;;;;;;;;;;;;; Reader conditionals ;;; parse trees -(defclass reader-conditional-form (form) ()) +(defclass reader-conditional-form (form) + ((%conditional-true-p :accessor conditional-true-p))) (defclass reader-conditional-positive-form (reader-conditional-form) ()) (defclass reader-conditional-negative-form (reader-conditional-form) ()) @@ -1833,6 +1834,20 @@ (progn (cache-symbol-info syntax symbol-form) (global-boundp symbol-form)))) +(defun cache-conditional-info (syntax form) + "Cache information about the reader conditional `symbol-form' represents, +so that it can be quickly looked up later." + (setf (conditional-true-p form) + (eval-feature-conditional (second-noncomment (children form)) syntax))) + +(defun reader-conditional-true (syntax form) + "Return true if the reader conditional `form' has a true +condition." + (if (slot-boundp form '%conditional-true-p) + (conditional-true-p form) + (progn (cache-conditional-info syntax form) + (conditional-true-p form)))) + (defun parenthesis-highlighter (view form) "Return the drawing style with which the parenthesis lexeme `form' should be highlighted." @@ -1844,6 +1859,23 @@ +bold-face-drawing-options+ +default-drawing-options+)) +(defun reader-conditional-rule-fn (positive comment-options) + "Return a function for use as a syntax highlighting +rule-generator for reader conditionals. If `positive', the +function will be for positive +reader-conditionals. `Comment-options' is the drawing options +object that will be returned when the conditional is not +fulfilled." + (if positive + #'(lambda (view form) + (if (reader-conditional-true (syntax view) form) + +default-drawing-options+ + (values comment-options t))) + #'(lambda (view form) + (if (not (reader-conditional-true (syntax view) form)) + +default-drawing-options+ + (values comment-options t))))) + (define-syntax-highlighting-rules emacs-style-highlighting (error-lexeme (*error-drawing-options*)) (string-form (*string-drawing-options*)) @@ -1857,18 +1889,29 @@ ((symbol-form-is-boundp (syntax view) form) *special-variable-drawing-options*) (t +default-drawing-options+))))) - (parenthesis-lexeme (:function #'parenthesis-highlighter))) + (parenthesis-lexeme (:function #'parenthesis-highlighter)) + (reader-conditional-positive-form + (:function (reader-conditional-rule-fn t *comment-drawing-options*))) + (reader-conditional-negative-form + (:function (reader-conditional-rule-fn nil *comment-drawing-options*)))) + +(defvar *retro-comment-drawing-options* + (make-drawing-options :face (make-face :ink +dimgray+)) + "The drawing options used for retro-highlighting in Lisp syntax.") (define-syntax-highlighting-rules retro-highlighting (error-symbol (*error-drawing-options*)) (string-form (:options :face +italic-face+)) - (comment (:face :ink +dimgray+)) + (comment (*retro-comment-drawing-options*)) (literal-object-form (:options :function (object-drawer))) (complete-token-form (:function #'(lambda (syntax form) (cond ((symbol-form-is-macrobound-p syntax form) +bold-face-drawing-options+) (t +default-drawing-options+))))) - ;; XXX: Ugh, copied from above. + (reader-conditional-positive-form + (:function (reader-conditional-rule-fn t *retro-comment-drawing-options*))) + (reader-conditional-negative-form + (:function (reader-conditional-rule-fn nil *retro-comment-drawing-options*))) (parenthesis-lexeme (:function #'parenthesis-highlighter))) (defparameter *syntax-highlighting-rules* 'emacs-style-highlighting --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/09 11:14:08 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/02/10 00:42:03 1.17 @@ -443,7 +443,18 @@ Alternatively, `type' can be any object (usually a dynamically bound symbol), in which case it will be evaluated to get the -drawing options." +drawing options. + +`Type' can also be a list, in which case the first element will +be interpreted as described above, and the remaining elements +will be considered keyword arguments. The following keyword +arguments are supported: + + `:sticky': if true, the syntax highlighting options defined by + this rule will apply to all children as well, effectively + overriding their options. The default is false. For a + `:function', `:sticky' will not work. Instead, return a true + secondary value from the function." (check-type name symbol) `(progn (fmakunbound ',name) @@ -451,18 +462,20 @@ (:method (view (parser-symbol parser-symbol)) nil)) ,@(flet ((make-rule-exp (type args) - (case type - (:face `(let ((options (make-drawing-options :face (make-face ,@args)))) - #'(lambda (view parser-symbol) - (declare (ignore view parser-symbol)) - options))) - (:options `#'(lambda (view parser-symbol) - (declare (ignore view parser-symbol)) - (make-drawing-options ,@args))) - (:function (first args)) - (t `#'(lambda (view parser-symbol) - (declare (ignore view parser-symbol)) - ,type))))) + (let ((actual-type (first (listed type)))) + (destructuring-bind (&key sticky) (rest (listed type)) + (case actual-type + (:face `(let ((options (make-drawing-options :face (make-face ,@args)))) + #'(lambda (view parser-symbol) + (declare (ignore view parser-symbol)) + (values options ,sticky)))) + (:options `#'(lambda (view parser-symbol) + (declare (ignore view parser-symbol)) + (values (make-drawing-options ,@args) ,sticky))) + (:function (first args)) + (t `#'(lambda (view parser-symbol) + (declare (ignore view parser-symbol)) + (values ,actual-type ,sticky)))))))) (loop for (parser-symbol (type . args)) in rules collect `(let ((rule ,(make-rule-exp type args))) (defmethod ,name (view (parser-symbol ,parser-symbol)) @@ -499,6 +512,18 @@ parser-symbol offset drawing-options highlighting-rules) +(defstruct (drawing-options-frame + (:constructor make-drawing-options-frame + (end-offset drawing-options sticky-p)) + (:conc-name frame-)) + "An entry in the drawing options stack maintained by the +`pump-state' structure. `End-offset' is the end buffer offset +for the frame, `drawing-options' is the drawing options that +should be used until that offset, and if `sticky-p' is true it +will not be possible to put other frames on top of this one in +the stack." + end-offset drawing-options sticky-p) + (defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) (syntax lr-syntax-mixin) (offset integer)) (update-parse syntax 0 (size (buffer view))) @@ -506,15 +531,18 @@ (highlighting-rules (syntax-highlighting-rules syntax))) (labels ((initial-drawing-options (parser-symbol) (if (null parser-symbol) - (cons (size (buffer view)) +default-drawing-options+) - (let ((drawing-options - (get-drawing-options highlighting-rules view parser-symbol))) + (make-drawing-options-frame + (size (buffer view)) +default-drawing-options+ nil) + (multiple-value-bind (drawing-options sticky) + (get-drawing-options highlighting-rules view parser-symbol) (if (null drawing-options) (initial-drawing-options (parent parser-symbol)) - (cons (end-offset parser-symbol) drawing-options)))))) + (make-drawing-options-frame (end-offset parser-symbol) + drawing-options sticky)))))) (make-pump-state parser-symbol offset (list (initial-drawing-options parser-symbol) - (cons (1+ (size (buffer view))) +default-drawing-options+)) + (make-drawing-options-frame + (1+ (size (buffer view))) +default-drawing-options+ nil)) highlighting-rules)))) (defun find-next-stroke-end (view pump-state) @@ -527,15 +555,16 @@ (highlighting-rules pump-state-highlighting-rules)) pump-state (let ((line (line-containing-offset (syntax view) offset))) - (flet ((finish (offset symbol &optional stroke-drawing-options) + (flet ((finish (new-offset symbol &optional stroke-drawing-options sticky-p) (setf start-symbol symbol) - (loop until (> (car (first drawing-options)) offset) - do (pop drawing-options)) (unless (null stroke-drawing-options) - (push (cons (end-offset symbol) stroke-drawing-options) + (push (if (frame-sticky-p (first drawing-options)) + (make-drawing-options-frame + (end-offset symbol) (frame-drawing-options (first drawing-options)) t) + (make-drawing-options-frame + (end-offset symbol) stroke-drawing-options sticky-p)) drawing-options)) - (return-from find-next-stroke-end - offset))) + (return-from find-next-stroke-end new-offset))) (cond ((null start-symbol) ;; This means that all remaining lines are blank. (finish (line-end-offset line) nil)) @@ -543,28 +572,38 @@ (= offset (start-offset start-symbol))) (finish (end-offset start-symbol) start-symbol nil)) (t - (or (do-parse-symbols-forward (symbol offset start-symbol) - (let ((symbol-drawing-options - (get-drawing-options highlighting-rules view symbol))) - (cond ((> (start-offset symbol) (line-end-offset line)) - (finish (line-end-offset line) start-symbol)) - ((and (typep symbol 'literal-object-mixin)) - (finish (start-offset symbol) symbol - (or symbol-drawing-options - (make-drawing-options :function (object-drawer))))) - ((and (> (start-offset symbol) offset) - (not (drawing-options-equal (or symbol-drawing-options - +default-drawing-options+) - (cdr (first drawing-options)))) - (if (null symbol-drawing-options) - (>= (start-offset symbol) (car (first drawing-options))) - t)) - (finish (start-offset symbol) symbol symbol-drawing-options)) - ((and (= (start-offset symbol) offset) - symbol-drawing-options - (not (drawing-options-equal symbol-drawing-options - (cdr (first drawing-options))))) - (finish (start-offset symbol) symbol symbol-drawing-options))))) + (or (let* ((current-frame (first drawing-options)) + (currently-used-options (frame-drawing-options current-frame))) + (do-parse-symbols-forward (symbol offset start-symbol) + (multiple-value-bind (symbol-drawing-options sticky) + (get-drawing-options highlighting-rules view symbol) + ;; Remove frames that are no longer applicable... + (loop until (> (frame-end-offset (first drawing-options)) + (start-offset symbol)) + do (pop drawing-options)) + (let ((options-to-be-used (if (frame-sticky-p (first drawing-options)) + (frame-drawing-options (first drawing-options)) + symbol-drawing-options))) + (cond ((> (start-offset symbol) (line-end-offset line)) + (finish (line-end-offset line) start-symbol)) + ((and (typep symbol 'literal-object-mixin)) + (finish (start-offset symbol) symbol + (or symbol-drawing-options + (make-drawing-options :function (object-drawer))))) + ((and (> (start-offset symbol) offset) + (not (drawing-options-equal (or options-to-be-used + +default-drawing-options+) + currently-used-options)) + (if (null symbol-drawing-options) + (>= (start-offset symbol) (frame-end-offset current-frame)) + t)) + (finish (start-offset symbol) symbol symbol-drawing-options sticky)) + ((and (= (start-offset symbol) offset) + symbol-drawing-options + (not (drawing-options-equal + options-to-be-used + (frame-drawing-options (first drawing-options))))) + (finish (start-offset symbol) symbol symbol-drawing-options sticky))))))) ;; If there are no more parse symbols, we just go ;; line-by-line from here. This should mean that all ;; remaining lines are blank. @@ -578,11 +617,15 @@ (with-accessors ((offset pump-state-offset) (current-drawing-options pump-state-drawing-options)) pump-state - (let ((old-drawing-options (cdr (first current-drawing-options))) - (end-offset (find-next-stroke-end view pump-state))) + (let ((old-drawing-options (frame-drawing-options (first current-drawing-options))) + (end-offset (find-next-stroke-end view pump-state)) + (old-offset offset)) (setf (stroke-start-offset stroke) offset (stroke-end-offset stroke) end-offset (stroke-drawing-options stroke) old-drawing-options offset (if (offset-end-of-line-p (buffer view) end-offset) (1+ end-offset) - end-offset)))))) + end-offset)) + ;; Don't use empty strokes, try again... + (when (= old-offset offset) + (stroke-pump-with-syntax view syntax stroke pump-state))))))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 08 Feb '08

08 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6421/Drei Modified Files: syntax.lisp Log Message: Fixed command table inheritance so syntax modes take precedence over the syntax itself. --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/30 11:48:40 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/02/08 18:37:32 1.18 @@ -43,7 +43,7 @@ (defgeneric syntax-command-tables (syntax) (:documentation "Returns additional command tables provided by `syntax'.") - (:method-combination append) + (:method-combination append :most-specific-last) (:method append ((syntax syntax)) (list (command-table syntax))))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 08 Feb '08

08 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31674/Drei Modified Files: lisp-syntax-commands.lisp Log Message: Added argument hinting for Lisp when entering newlines and right parentheses. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2008/01/17 11:29:55 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2008/02/08 18:05:51 1.17 @@ -90,16 +90,21 @@ "Show argument list for a given symbol." (show-arglist (current-syntax) symbol)) -(define-command (com-space :command-table lisp-table) +(define-command (com-self-insert-then-arglist :command-table lisp-table) () - "Insert a space and display argument hints in the minibuffer." - (insert-character #\Space) - ;; We must update the syntax in order to reflect any changes to - ;; the parse tree our insertion of a space character may have - ;; done. + "Insert the gesture used to invoke this command and display +argument hints in the minibuffer." + (insert-character *current-gesture*) (show-arglist-for-form-at-mark (point) (current-syntax)) (clear-completions)) +(define-command (com-newline-indent-then-arglist :command-table lisp-table) () + "Inserts a newline, indents the new line, then displays +argument hints in the minibuffer." + (insert-object (point) #\Newline) + (indent-current-line (current-view) (point)) + (show-arglist-for-form-at-mark (point) (current-syntax))) + (define-command (com-complete-symbol :name t :command-table lisp-table) () "Attempt to complete the symbol at mark. If successful, move point @@ -216,10 +221,14 @@ 'lisp-table '((#\c :control) (#\d :control) (#\a))) -(set-key 'com-space +(set-key 'com-self-insert-then-arglist 'lisp-table '((#\Space))) +(set-key 'com-self-insert-then-arglist + 'lisp-table + '((#\)))) + (set-key 'com-complete-symbol 'lisp-table '((#\Tab :meta))) @@ -232,7 +241,7 @@ 'lisp-table '((#\Tab))) -(set-key 'drei-commands::com-newline-and-indent +(set-key 'com-newline-indent-then-arglist 'lisp-table '(#\Newline))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 08 Feb '08

08 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv19251/Drei Modified Files: input-editor.lisp Log Message: Finally make that ridiculously complated input-editor do as I want it do to! Slowish, but who cares? Perhaps the input-editor needs a special buffer implementation... --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 12:43:59 1.45 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 13:24:48 1.46 @@ -558,9 +558,11 @@ if stuff is inserted after the insertion pointer." (assert (<= (input-position stream) (stream-scan-pointer stream))) (let* ((drei (drei-instance stream)) + (buffer (buffer (view drei))) (*command-processor* drei) (was-directly-processing (directly-processing-p drei)) - (*drei-input-editing-stream* stream)) + (*drei-input-editing-stream* stream) + (old-buffer-contents (buffer-sequence buffer 0 (size buffer)))) (with-bound-drei-special-variables (drei :prompt "M-x ") (update-drei-buffer stream) ;; Commands are permitted to signal immediate rescans, but @@ -573,7 +575,7 @@ (drei-core:with-narrowed-buffer (drei (loop for index from (1- (input-position stream)) above 0 - when (typep (buffer-object (buffer (view drei)) index) + when (typep (buffer-object buffer index) 'noise-string) return (1+ index) finally (return 0)) @@ -589,8 +591,7 @@ (when was-directly-processing (display-message "Aborted"))))))) (update-drei-buffer stream)) - (let ((first-mismatch (when (plusp (prefix-size (view drei))) - (prefix-size (view drei))))) + (let ((first-mismatch (buffer-array-mismatch buffer old-buffer-contents))) (display-drei drei :redisplay-minibuffer t) (cond ((null first-mismatch) ;; No change actually took place, even though IP may

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 08 Feb '08

08 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv2460/Drei Modified Files: input-editor.lisp Log Message: Now actually fixed some more things. Net result: input-editing should be more stable and predictable. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 11:36:35 1.44 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 12:43:59 1.45 @@ -556,6 +556,7 @@ `stream-read-gesture' for the stream encapsulated by `stream'. The second return value of this function will be `type' if stuff is inserted after the insertion pointer." + (assert (<= (input-position stream) (stream-scan-pointer stream))) (let* ((drei (drei-instance stream)) (*command-processor* drei) (was-directly-processing (directly-processing-p drei)) @@ -588,13 +589,14 @@ (when was-directly-processing (display-message "Aborted"))))))) (update-drei-buffer stream)) - (let ((first-mismatch (prefix-size (view drei)))) + (let ((first-mismatch (when (plusp (prefix-size (view drei))) + (prefix-size (view drei))))) (display-drei drei :redisplay-minibuffer t) (cond ((null first-mismatch) ;; No change actually took place, even though IP may ;; have moved. nil) - ((<= first-mismatch (stream-scan-pointer stream)) + ((< first-mismatch (stream-scan-pointer stream)) ;; Eek, change before scan pointer - this probably ;; changes the scan, so we'll have to rescan ;; everything. Bummer!

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 08 Feb '08

08 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv16323/Drei Modified Files: input-editor.lisp Log Message: Fixed yet another random input-editor issue. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 11:29:17 1.43 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 11:36:35 1.44 @@ -594,7 +594,7 @@ ;; No change actually took place, even though IP may ;; have moved. nil) - ((< first-mismatch (stream-scan-pointer stream)) + ((<= first-mismatch (stream-scan-pointer stream)) ;; Eek, change before scan pointer - this probably ;; changes the scan, so we'll have to rescan ;; everything. Bummer!

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 08 Feb '08

08 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv14662/Drei Modified Files: input-editor.lisp Log Message: Removed stale hack. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 11:17:08 1.42 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 11:29:17 1.43 @@ -625,15 +625,9 @@ (setf (activation-gesture stream) gesture) (rescan-if-necessary stream) (return-from stream-process-gesture gesture)) - ;; XXX: The problem is that `*original-stream*' is a subclass of - ;; DREI-INPUT-EDITING-MIXIN (`stream', actually) at this point, - ;; which has an array as input buffer (as demanded by the spec), - ;; while the `stream-unread-gesture' method expects an event queue. - (let ((*original-stream* nil) - (*standard-input* (encapsulating-stream-stream stream))) - (when (proper-gesture-p gesture) - (unread-gesture gesture)) - (read-gestures-and-act stream gesture type))) + (when (proper-gesture-p gesture) + (unread-gesture gesture :stream (encapsulating-stream-stream stream))) + (read-gestures-and-act stream gesture type)) (defmethod reset-scan-pointer ((stream drei-input-editing-mixin) &optional (scan-pointer 0))

1 0