[mcclim-cvs] CVS mcclim/Drei

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv6678/Drei

Modified Files:
	base.lisp editing.lisp motion.lisp packages.lisp 
Log Message:
Fixed some word-motion and word-transposition bugs.


--- /project/mcclim/cvsroot/mcclim/Drei/base.lisp	2008/01/02 14:43:40	1.9
+++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp	2008/01/05 20:08:32	1.10
@@ -431,6 +431,12 @@
      until (offset-end-of-line-p buffer offset)
      finally (return offset)))
 
+(defun extract-region (mark-or-offset1 mark-or-offset2)
+  "Delete the region delimited by `mark-or-offset1' and
+`mark-or-offset2', returning the extracted sequence of objects."
+  (prog1 (region-to-sequence mark-or-offset1 mark-or-offset2)
+    (delete-region mark-or-offset1 mark-or-offset2)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 
 ;;; Character case
--- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp	2007/12/21 14:22:07	1.9
+++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp	2008/01/05 20:08:32	1.10
@@ -176,42 +176,50 @@
             ,(concat "Transpose two " plural " at MARK.")))
          (defmethod ,transpose
              ((mark right-sticky-mark) syntax)
-           (let (start1 end1 start2 end2)
-             (,backward mark syntax 1 nil)
-             (setf start1 (clone-mark mark))
-             (,forward mark syntax 1 #'error-limit-action)
-             (setf end1 (clone-mark mark))
-             (,forward mark syntax 1 #'error-limit-action)
-             (setf end2 (clone-mark mark))
-             (,backward mark syntax 1 nil)
-             (setf start2 (clone-mark mark))
-             (let ((obj1 (buffer-sequence (buffer mark) (offset start1) (offset end1)))
-                   (obj2 (buffer-sequence (buffer mark) (offset start2) (offset end2))))
-               (,forward-delete mark syntax 1 nil)
-               (insert-sequence mark obj1)
-               (,backward mark syntax 2 nil)
-               (,forward-delete mark syntax 1 nil)
-               (insert-sequence mark obj2)
-               (,forward mark syntax 1 nil))))
+           (let ((start1 (clone-mark mark)))
+             (,backward start1 syntax 1 nil)
+             (let ((end1 (clone-mark start1)))
+               (,forward end1 syntax 1 #'error-limit-action)
+               (let ((start2 (clone-mark end1)))
+                 (,forward start2 syntax 1 #'error-limit-action)
+                 (let ((end2 (clone-mark start2)))
+                   (,backward start2 syntax 1 nil)
+                   (as-region (start1 end1)
+                     (as-region (start2 end2)
+                       (when (mark> start1 start2)
+                         (psetf start1 start2
+                                end1 end2
+                                start2 start1
+                                end2 end1))
+                       (if (mark> end1 start2)
+                           (error-limit-action mark (offset mark) 0 ,unit-name syntax)
+                           (let ((obj2 (extract-region start2 end2)))
+                             (insert-sequence start2 (extract-region start1 end1))
+                             (insert-sequence start1 obj2)
+                             (setf (offset mark) (offset end2)))))))))))
          (defmethod ,transpose
              ((mark left-sticky-mark) syntax)
-           (let (start1 end1 start2 end2)
-             (,backward mark syntax 1 nil)
-             (setf start1 (clone-mark mark))
-             (,forward mark syntax 1 #'error-limit-action)
-             (setf end1 (clone-mark mark))
-             (,forward mark syntax 1 #'error-limit-action)
-             (setf end2 (clone-mark mark))
-             (,backward mark syntax 1 nil)
-             (setf start2 (clone-mark mark))
-             (let ((obj1 (buffer-sequence (buffer mark) (offset start1) (offset end1)))
-                   (obj2 (buffer-sequence (buffer mark) (offset start2) (offset end2))))
-               (,forward-delete mark syntax 1 nil)
-               (insert-sequence mark obj1)
-               (,forward mark syntax 1 nil)
-               (,backward mark syntax 2 nil)
-               (,forward-delete mark syntax 1 nil)
-               (insert-sequence mark obj2))))))))
+           (let ((start1 (clone-mark mark)))
+             (,backward start1 syntax 1 nil)
+             (let ((end1 (clone-mark start1)))
+               (,forward end1 syntax 1 #'error-limit-action)
+               (let ((start2 (clone-mark end1)))
+                 (,forward start2 syntax 1 #'error-limit-action)
+                 (let ((end2 (clone-mark start2)))
+                   (,backward start2 syntax 1 nil)
+                   (as-region (start1 end1)
+                     (as-region (start2 end2)
+                       (when (mark> start1 start2)
+                         (psetf start1 start2
+                                end1 end2
+                                start2 start1
+                                end2 end1))
+                       (if (mark> end1 start2)
+                           (error-limit-action mark (offset mark) 0 ,unit-name syntax)
+                           (let ((obj2 (extract-region start2 end2)))
+                             (insert-sequence start2 (extract-region start1 end1))
+                             (insert-sequence start1 obj2)
+                             (setf (offset mark) (offset end2)))))))))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 
--- /project/mcclim/cvsroot/mcclim/Drei/motion.lisp	2007/08/20 19:44:44	1.5
+++ /project/mcclim/cvsroot/mcclim/Drei/motion.lisp	2008/01/05 20:08:32	1.6
@@ -267,24 +267,24 @@
 Return T if successful, or NIL if the buffer limit was reached."))
 
 (defmethod forward-one-word (mark syntax)
-  (forward-to-word-boundary mark syntax)
-  (and (not (end-of-buffer-p mark))
-       (loop until (end-of-buffer-p mark)
-          while (word-constituentp syntax (object-after mark))
-          do (forward-object mark)
-          finally (return t))))
+  (unless (end-of-buffer-p mark)
+    (forward-to-word-boundary mark syntax)
+    (loop until (end-of-buffer-p mark)
+       while (word-constituentp syntax (object-after mark))
+       do (forward-object mark)
+       finally (return t))))
 
 (defgeneric backward-one-word (mark syntax)
   (:documentation "Move MARK backward over the previous word.
 Return T if successful, or NIL if the buffer limit was reached."))
 
 (defmethod backward-one-word (mark syntax)
-  (backward-to-word-boundary mark syntax)
-  (and (not (beginning-of-buffer-p mark))
-       (loop until (beginning-of-buffer-p mark)
-          while (word-constituentp syntax (object-before mark))
-          do (backward-object mark)
-          finally (return t))))
+  (unless (beginning-of-buffer-p mark)
+    (backward-to-word-boundary mark syntax)
+    (loop until (beginning-of-buffer-p mark)
+       while (word-constituentp syntax (object-before mark))
+       do (backward-object mark)
+       finally (return t))))
 
 (define-motion-fns word)
 
--- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp	2008/01/05 09:17:37	1.32
+++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp	2008/01/05 20:08:32	1.33
@@ -111,6 +111,7 @@
            #:offset-beginning-of-line-p
            #:offset-end-of-line-p
            #:end-of-line-offset
+           #:extract-region
            #:buffer-whitespacep
            #:buffer-region-case
            #:buffer-looking-at #:looking-at